VBA Копирование и вставка данных из уникальных рабочих книг в пользовательском каталоге в основную рабочую книгу

Question

Я относительно новичок в VBA и пытаюсь создать код для копирования данных из приблизительно 130 файлов xls в указанный пользователем каталог и вставки их в основную рабочую книгу. Все рабочие книги и рабочие таблицы в каталоге имеют уникальные имена.

Данные, которые мне нужно скопировать, находятся в C2: J2 каждого файла и должны быть вставлены в мастер-лист, начиная с A2: H2 и заполняя следующую Строка вниз, пока не будет достигнут конец файлов.

Я хотел бы l oop через все файлы в каталоге.

Я пробовал несколько вариантов кода, чтобы сделать это и не могу, кажется, получить это. Мне удалось заставить макрос открыть каталог, и он, похоже, начинает процесс, но не копирует и не вставляет данные в мою главную рабочую таблицу. Вот каталог к ​​моей главной рабочей таблице, и я вставил код ниже.

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

End Sub