CODEWITHSUNDEEP
excelvba
Raphael
Raphael

Reputation: 1

Copy n Rows from Sheet and append to current Workbook&Sheet

I'm trying to loop through all workbooks in a given directory, open the workbook, loop through the sheets, copy the first 14 rows of each sheet and append them to the currently open sheet.

So far i've got the sheet.copy to just plant the sheets in the workbook but am missing the last step: copying the first 14 rows of each sheet into the currently open sheet. The sheet where the rows are supposed to be listed is initially empty, in case that makes a difference.

Sub GetSheets()

Path = "F:\_Projekttiming\Wochenplanung\Einzelne_Dateien\"
Filename = Dir(Path & "*.xlsx")

Do While Filename <> ""
  Workbooks.Open Filename:=Path & Filename, ReadOnly:=True

  For Each Sheet In ActiveWorkbook.Sheets
    Sheet.Copy After:=ThisWorkbook.Sheets(1)

  Next Sheet

  Workbooks(Filename).Close
  Filename = Dir()
Loop

End Sub

Any help on this is greatly apprechiated :)

Upvotes: 0

Views: 110

Answers (1)

SJR
SJR

Reputation: 23081

You don't need to copy the sheets, just copy the contents of the 14 rows (do you really need the entire row?)

You may need to adjust the destination sheet, which I have assumed is the first sheet in the workbook containing the macro.

A good idea too to get in the habit of declaring your variables, and assigning objects to them (e.g. wb) so you can reference them more efficiently.

Sub GetSheets()

Dim wb As Workbook, Path As String, FileName, sheet As Worksheet

Path = "F:\_Projekttiming\Wochenplanung\Einzelne_Dateien\"
FileName = Dir(Path & "*.xlsx")

Do While FileName <> ""
    Set wb = Workbooks.Open(FileName:=Path & FileName, ReadOnly:=True)
    For Each sheet In wb.Worksheets
        sheet.Range("A1").EntireRow.Resize(14).Copy ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp)(2)
    Next sheet
    wb.Close
    FileName = Dir()
Loop

End Sub

Upvotes: 1

Related Questions