读取Excel文件而不打开它，然后将内容复制到列的第一个空白单元格上 [英] Read Excel file without opening it and copy contents on column first blank cell

问题描述

因此，我想借助Macro来自动执行很多复制/粘贴的手动工作.宏应一一读取文件夹中的所有文件，复制该源文件范围"I9:J172"中的内容，然后将其粘贴到目标文件中(当然是宏)在列的第一空白行上.

So I want to automate a lot of manual work of copy/paste with the help of a Macro. The macro should read all files from folder one by one, copy the content from that source file range "I9:J172" and paste it on the destination file (where the macro is of course) on the column first blank row.

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

我想先解决最后一行的问题，然后做一个数组和一个循环以逐个读取所有文件.

I want to solve first this last row problem and then do an array and the loop to read all the files one by one.

谢谢！

推荐答案

以下代码完成了您描述的内容，并且gif动画效果通过3个测试文件进行了演示(在您提到的列中包含测试数据).gif的第一部分显示了两个测试文件的内容，然后运行该宏，逐步执行该宏，并在组合"工作表上显示了结果.单击gif以查看更多详细信息.请注意，每个测试文件的数据必须在数据"表上.您当然可以修改.

The following code does what you've described, and the animated gif demonstrates with 3 test files (with test data in the columns you mentioned). The first part of the gif shows the contents of 2 of the test files, and then runs the macro, stepping through it, showing the result on a "combined" sheet. Click on the gif to see better detail. Note that each test file's data must be on a "data" sheet. You can modify, of course.

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

这篇关于读取Excel文件而不打开它，然后将内容复制到列的第一个空白单元格上的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！