Поэтому я хочу автоматизировать большую часть ручной работы по копированию / вставке с помощью макроса. Макрос должен прочитать все файлы из папки один за другим, скопировать содержимое из этого диапазона исходных файлов «I9: J172» и вставить его в целевой файл (где, конечно, находится макрос) в первую пустую строку столбца.

Application.ScreenUpdating = False

'For Each Item In franquicia

    ' OPEN THE SOURCE EXCEL WORKBOOK IN "READ ONLY MODE".
    Set src = Workbooks.Open("C:\folder\inventory.xlsb", True, True)

    ' GET THE TOTAL ROWS FROM THE SOURCE WORKBOOK.
    Dim iTotalRows As Integer
    iTotalRows = src.Worksheets("INV").Range("I9:J" & Cells(Rows.Count, "J").End(xlUp).Row).Rows.Count

    ' FIND FIRST BLANK CELL
    Dim LastRow As Long
    LastRow = Worksheets("Hoja1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

    ' COPY DATA FROM SOURCE (CLOSE WORKGROUP) TO THE DESTINATION WORKBOOK.
    Dim iCnt As Integer         ' COUNTER.
    For iCnt = 1 To iTotalRows
        Worksheets("Hoja1").Range("A" & LastRow & ":B" & iCnt).Value = src.Worksheets("INV").Range("I9:J172" & iCnt).Value
    Next iCnt

    ' CLOSE THE SOURCE FILE.
    src.Close False             ' FALSE - DON'T SAVE THE SOURCE FILE.
    Set src = Nothing

'Next Item

Я хочу сначала решить эту проблему с последней строкой, а затем создать массив и цикл для чтения всех файлов один за другим.

Спасибо!

1
KronosL 12 Мар 2018 в 21:53

2 ответа

Лучший ответ

Следующий код выполняет то, что вы описали, а анимированный gif демонстрирует 3 тестовых файла (с тестовыми данными в упомянутых вами столбцах). Первая часть гифки показывает содержимое двух тестовых файлов, а затем запускает макрос, шагая по нему, показывая результат на «комбинированном» листе. Нажмите на гифку, чтобы увидеть подробности. Обратите внимание, что данные каждого тестового файла должны быть на листе «данных». Вы, конечно, можете модифицировать.

enter image description here

Option Explicit
Dim theDir As String, alreadyThere As Boolean, wk As Workbook
Dim sh As Worksheet, comboSh As Worksheet, comboR As Range
Dim r As Range, s As String, numFiles As Integer
Const ext = ".xlsx"

Sub CombineFiles()
  Set comboSh = getSheet(ThisWorkbook, "Combined", True)
  theDir = ThisWorkbook.Path
  s = Dir(theDir & "\*" & ext)
  Set comboR = comboSh.Range("A1")
  While s <> ""
    ThisWorkbook.Activate
    If comboR <> "" Then Set comboR = comboR.Offset(0, 2)
    comboR.Activate
    Set wk = Workbooks.Open(theDir & "\" & s)
    Set sh = getSheet(wk, "data", False)
    Set r = sh.Range("I9:J72")
    'Set r = sh.Range(r, r.End(xlToRight))
    'Set r = sh.Range(r, r.End(xlDown))
    r.Copy
    comboSh.Paste
    Application.DisplayAlerts = False
    wk.Close False
    Application.DisplayAlerts = True
    s = Dir()
    numFiles = numFiles + 1
  Wend
  MsgBox ("done")
End Sub
Function getSheet(wk As Workbook, shName As String, makeIfAbsent As Boolean) As Worksheet
  alreadyThere = False
  For Each sh In wk.Worksheets
    If sh.Name = shName Then
      alreadyThere = True
      Set getSheet = sh
    End If
  Next
  If Not alreadyThere Then
    If makeIfAbsent Then
      Set getSheet = wk.Sheets.Add
      getSheet.Name = shName
     Else
      MsgBox shName & " sheet not found -- ending"
      End
    End If
  End If
End Function
2
Tony M 12 Мар 2018 в 19:47

Возможно, я приду на вечеринку слишком поздно. Похоже, вы получили то решение, которое искали. Для дальнейшего использования попробуйте надстройку ниже. Это будет выполнять все виды задач копирования / вставки / слияния.

https://www.rondebruin.nl/win/addins/rdbmerge.htm

enter image description here

-1
ASH 29 Мар 2018 в 02:15