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

Question

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

我需要复制的数据在每个文件的C2:J2中，需要从A2:H2开始粘贴到主工作表中，并向下填充下一行，直到文件结束。

我想循环浏览该目录中的所有文件。

我已经尝试了多种不同的代码来实现这个目标，但似乎无法实现。我已经能够让宏打开目录，似乎开始了这个过程，但没有将数据复制和粘贴到我的主工作表中。这是我的主工作表的目录，我把代码粘贴到下面。

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

结束子