CODEWITHSUNDEEP
excelvba
KronosL
KronosL

Reputation: 309

Read Excel file without opening it and copy contents on column first blank cell

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.

Thank you!

Upvotes: 1

Views: 27406

Answers (2)

ASH
ASH

Reputation: 20302

I may be arriving to the party too late. It seems like you got the solution you were after. For future reference, try the AddIn below. This will do all kinds of copy/paste/merge tasks.

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

enter image description here

Upvotes: -1

Tony M
Tony M

Reputation: 1762

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.

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

Upvotes: 3

Related Questions