VBA 将用户定义目录中唯一工作簿中的数据复制并粘贴到主工作簿

Question

我对 VBA 比较陌生，我正在尝试创建代码以从用户指定目录中的大约 130 个 xls 文件复制数据并将其粘贴到主工作簿中。目录中的工作簿和作品sheet都有唯一的名称。

我需要复制的数据在每个文件的C2:J2中，需要粘贴到母版sheet中，从A2:H2开始，向下填充下一行，直到结束已达到文件数。

我想遍历目录中的所有文件。

我已经尝试了多种代码变体来执行此操作，但似乎无法实现。我已经能够让宏打开目录，它似乎开始了这个过程，但没有将数据复制并粘贴到我的主作品中sheet。这是我的主要作品 sheet 的目录，我已经粘贴了下面的代码。

C:\Users\krist\Desktop\TestModifiedCalculated\Compiled.xlsm\

非常感谢！！

Sub CompileData()
    Dim xRg As Range
    Dim xSelItem As Variant
    Dim xFileDlg As FileDialog
    Dim xFileName, xSheetName, xRgStr As String
    Dim xBook, xWorkBook As Workbook
    Dim xSheet As Worksheet
    On Error Resume Next
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    xSheetName = "Sheet1"
    xRgStr = "C2:J2"
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    With xFileDlg
        If .Show = -1 Then
            xSelItem = .SelectedItems.Item(1)
            Set xWorkBook = ThisWorkbook
            Set xSheet = xWorkBook.Sheets("New Sheet")
            If xSheet Is Nothing Then
                xWorkBook.Sheets.Add(After:=xWorkBook.Worksheets(xWorkBook.Worksheets.Count)).Name = "New Sheet"
                Set xSheet = xWorkBook.Sheets("New Sheet")
            End If
            xFileName = Dir(xSelItem & "\*.xls", vbNormal)
            If xFileName = "" Then Exit Sub
            Do Until xFileName = ""
               Set xBook = Workbooks.Open(xSelItem & "\" & xFileName)
                Set xRg = xBook.Worksheets(xSheetName).Range(xRgStr)
                xRg.Copy xSheet.Range("A65536").End(xlUp).Offset(1, 0)
                xFileName = Dir()
                xBook.Close
            Loop
        End If
    End With
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Answer 1

略有不同的方法。希望这可以帮助。

Sub ModSub()

Dim CopyRangeSt As String
CopyRangeSt = "C2:J2"

Dim PasteRangeSt As String
PasteRangeSt = "A2:H2"

Dim MasterWorkBook As Workbook
Set MasterWorkBook = ThisWorkbook

Dim MasterSheet As Worksheet
Set MasterSheet = MasterWorkBook.Sheets(1)


Dim SelectedPath As String
Dim counter As Long
counter = 0

'Open FileDialog to Select the Files not Directory
Dim FileDiag As FileDialog
Dim fileCount As Long

Set FileDiag = Application.FileDialog(msoFileDialogFilePicker)
    With FileDiag
        .AllowMultiSelect = True
        .Show
     End With


'Files were selected
If FileDiag.SelectedItems.Count > 0 Then

'Process Each File path. Check for .xlsx and xlsm extension to ensure you're working with Excel Files only
'Add Checked file paths to DataExcelFiles Collection. Skipping for my time here
For fileCount = 1 To FileDiag.SelectedItems.Count

'Use only Excel Files in your application
Dim dataBook As Workbook
Set dataBook = Workbooks.Open(FileDiag.SelectedItems(fileCount))

'Assuming Data is only on the first sheet
Dim dataSheet As Worksheet
Set dataSheet = dataBook.Sheets(1)

'Counter will be offsetting the row for each range of data you need pasted
MasterSheet.Range(PasteRangeSt).Offset(counter) = dataSheet.Range(CopyRangeSt).Value
counter = counter + 1

Next fileCount

End If

结束子

VBA 将用户定义目录中唯一工作簿中的数据复制并粘贴到主工作簿

VBA Copy and paste data from unique workbooks in a user defined directory to a master workbook

excel

vba

copy-paste