无需打开即可读取Excel文件，并在第一列空白单元格中复制内容

Question

所以我希望在Macro的帮助下自动完成大量的复制/粘贴手动工作。宏应该逐个读取文件夹中的所有文件，从该源文件范围中复制内容＆＃34; I9：J172＆＃34;并将其粘贴到第一个空白行列的目标文件（当然是宏）。

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

我想首先解决这个最后一行问题，然后做一个数组和循环来逐个读取所有文件。

谢谢！

Answer 1

以下代码执行您所描述的内容，动画gif演示了3个测试文件（在您提到的列中包含测试数据）。 gif的第一部分显示了2个测试文件的内容，然后运行宏，逐步执行它，在“组合”工作表上显示结果。点击gif查看更多细节。请注意，每个测试文件的数据必须位于“数据”表中。当然，你可以修改。

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

Answer 2

我可能来得太晚了。看起来你得到了你所追求的解决方案。为了将来参考，请尝试下面的AddIn。这将执行各种复制/粘贴/合并任务。

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