VBA - копирование и вставка из нескольких файлов Excel в один файл Excel

Question

Долгое время читатель и поклонник StackOverflow.

В основном я пытаюсь выполнить цикл файлов Excel, чтобы скопировать ряд данных и вставить их в одну книгу/лист Excel.

Не всегда согласовано расположение диапазона ячеек (C3: D8, D3: E8), но размеры таблицы: 29 R x 2 C. Кроме того, файлы имеют только 1 лист, и кроме указанных размеров таблицы , никаких значений данных в других ячейках.

В текущей форме код выполняет, но не вставляет ничего в его целевой файл Excel.

мне это нужно, чтобы

1. Найти размерность данных в файл (таблица)
2. Скопируйте таблицу
3. Вставить в пункт назначения (ниже предыдущей таблицы)
4. Loop через к следующему файлу
5. Повторите шаг 1-4

Код от:

Большое спасибо за любую помощь, я очень ценю это и, пожалуйста, скажите мне указать что-либо, если мой вопрос неясен.

Sub SourcetoDest() 

    Dim wbDest As Workbook 
    Dim wbSource As Workbook 
    Dim sDestPath As String 
    Dim sSourcePath As String 
    Dim shDest As Worksheet 
    Dim rDest As Range 
    Dim vaFiles As Variant 
    Dim i As Long 

    'array of folder names under sDestPath 

    'array of file names under vaFiles 
    vaFiles = Array("Book1.xls") 

    sDestPath = "C:\Users" 
    sSourcePath = "C:\Users" 


    Set wbDest = Workbooks.Open(sDestPath & "\" & "Book2.xlsm") 
    Set shDest = wbDest.Sheets(1) 

    'loop through the files 
    For i = LBound(vaFiles) To UBound(vaFiles) 
     'open the source 
     Set wbSource = Workbooks.Open(sSourcePath & "\" & vaFiles(i)) 

     'find the next cell in col C 
     Set rDest = shDest.Cells(shDest.Rows.Count, 3).End(xlUp).Offset(1, 0) 
     'write the values from source into destination 
     rDest.Resize(5, 1).Value = wbSource.Sheets(1).Range("C7:D33").Value 


     wbSource.Close False 
    Next i 

End Sub 

Answer 1

Ниже должно быть достигнуто то, что вам нужно.

Option Explicit 
Sub copy_rng() 
    Dim wb As Workbook, wbDest As Workbook, ws As Worksheet, wsDest As Worksheet, wsSrc As Worksheet 
    Dim wbNames() As Variant 
    Dim destFirstCell As Range 
    Dim destColStart As Integer, destRowStart As Long, i As Byte 
    Dim destPath As String 

    Set wb = ThisWorkbook 
    Set ws = wb.Sheets("Sheet1") ' Amend to your sheet name 
    Set wsSrc = wb.Sheets("Sheet2") ' Amend to sheet name with table data 
    wbNames = ws.Range("A2:A" & lrow(1, ws)) ' Pass col number into lrow function 
    destPath = "C:\Users\" 

    Application.ScreenUpdating = False 
    For i = 1 To UBound(wbNames, 1) 
     Set wbDest = Workbooks.Open(destPath & wbNames(i, 1)) 
     Set wsDest = wbDest.Worksheets(1) 
     With wsDest 
      Set destFirstCell = .Cells.Find(What:="*") 
      destColStart = destFirstCell.Column 
      destRowStart = destFirstCell.Row 
      .Range(Cells(destRowStart, destColStart), _ 
       Cells(lrow(destColStart, wsDest), icol(destRowStart, wsDest))).Copy 
     End With 
     wsSrc.Cells(lrow(1, wsSrc) + 1, 1).PasteSpecial Paste:=xlPasteAll 
     wbDest.Close False 
    Next i 
    Application.ScreenUpdating = True 

End Sub 

Function lrow(ByVal col_num As Integer, sheet_name As Worksheet) As Long 
    lrow = sheet_name.Cells(Rows.Count, col_num).End(xlUp).Row 
End Function 

Function icol(ByVal row_num As Long, sheet_name As Worksheet) As Integer 
    icol = sheet_name.Cells(row_num, Columns.Count).End(xlToLeft).Column 
End Function 

Убедитесь, что вы скопировать обе функции в поперечнике, они используются для создания размеров таблицы, а затем скопировать таблицу.

Вам нужно будет изменить переменные названия листа. Дайте знать, если у вас появятся вопросы.

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