• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Loop through sheets & workbooks to copy

S

Sameer.k21

Member
Hi All,

here I am again with new issue.
I have a code which needs some correction/advice.

I have multiple workbooks & in them some have 3 sheets, some 4 and some 7 sheets. The code loops through only through the 1st sheet of each book and copies even the headers.

Code: 
Sub LoopThroughFiles()
Dim intChoice As Integer
Dim strPath, fname As String
Dim MyObj As Object, MySource As Object, file As Variant
  
  file = Dir("C:\Desktop\My Documents")
  
  Range("A2").Select
  Workbooks.Add
  ChDir "C:\Desktop"
  ActiveWorkbook.SaveAs filename:="C:\Desktop\Consolidated.xlsx"
  
  Application.FileDialog(msoFileDialogOpen).AllowMultiSelect = False
  While (file <> "")
  Workbooks("Consolidated.xlsx").Activate
  Workbooks.Open filename:=file
  ActiveWorkbook.Activate
  
  Range("A2").Select
  Range(Selection, Selection.End(xlToRight)).Select
  Range(Selection, Selection.End(xlDown)).Select
  Selection.Copy
  Workbooks("Consolidated.xlsx").Activate
  Range("A2").Select
  If Range("A2").Value = "" Then
  ActiveSheet.Paste
  Else
  Selection.End(xlDown).Select
  ActiveCell.Offset(1, 0).Select
  
  ActiveSheet.Paste
  End If
  Workbooks.Open filename:=file
  ActiveWorkbook.Close
  file = Dir
  Wend
End Sub

headers are same for all the sheets and workbooks, the data changes. I am trying a code to run, loop through the sheets in each WB, copy data from A2 till the last colum and row. Go to new created wb and dump everything in sheet1 ONLY.
 

Attachments

  • Sampleloopsheets2.xlsm
    24.7 KB · Views: 2
  • Sampleloopsheets1.xlsm
    24.6 KB · Views: 2
What are u looking!
Copy 1st sheet from each workbook & make a separate wb for the same.
or
Copy 1st sheet from each workbook & make a sheet with compiled data.
 
Copy each sheet from each wb and make newbook with 1st sheet to have data from all sheets and workbooks in that folder.
 
check it

Code: 
Option Explicit
Sub test()
Dim r As Integer, myws As Worksheet, fol As String, wb As String, mywb As Workbook, ws As Worksheet, lrow As Integer

Application.ScreenUpdating = False

With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False:    .Show
    On Error Resume Next: fol = .SelectedItems(1): Err.Clear: On Error GoTo 0
End With

fol = fol & "\":    wb = Dir(fol & "*.xls*")
If wb = "" Then Exit Sub

lrow = 2
    Do While wb <> ""
    If Not wb <> ThisWorkbook.Name Then GoTo n
    r = 0
        Set mywb = Workbooks.Open(fol & wb):    mywb.Sheets(1).Cells(999, 999).Name = "dest"
            For Each ws In mywb.Worksheets
                With ws.Cells(1, 1).CurrentRegion
                    .Offset(1).Resize(.Rows.Count - 1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[dest].Offset(r), Unique:=False
                    r = r + .Rows.Count - 1
                End With
            Next

            [dest].CurrentRegion.Copy: ThisWorkbook.Sheets(1).Cells(lrow, 1).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            lrow = lrow + r:        mywb.Close 0
n:  wb = Dir
  Loop

Application.ScreenUpdating = True

End Sub
 
Last edited:
I get error here : "The extract range has a missing or invalid field name"

.Offset(1).Resize(.Rows.Count - 1).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=[dest].Offset(r), Unique:=False
 
One more variant is here!


Code: 
Option Explicit
Sub loop2()
Dim fol As String, wb As String, mywb As Workbook, ws As Worksheet, lrow As Integer

Application.ScreenUpdating = False

With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False:    .Show
    On Error Resume Next: fol = .SelectedItems(1): Err.Clear: On Error GoTo 0
End With

fol = fol & "\":    wb = Dir(fol & "*.xls*")
If wb = "" Then Exit Sub

lrow = 2
    Do While wb <> ""
    If Not wb <> ThisWorkbook.Name Then GoTo n
        Set mywb = Workbooks.Open(fol & wb)
            For Each ws In mywb.Worksheets
                With ws.Cells(1, 1).CurrentRegion
                    .Offset(1).Resize(.Rows.Count - 1).Copy
                    ThisWorkbook.Sheets(1).Cells(lrow, 1).PasteSpecial xlPasteValues
                    Application.CutCopyMode = False: lrow = lrow + .Rows.Count - 1
                End With
            Next
        mywb.Close 0
n:  wb = Dir
    Loop

Application.ScreenUpdating = True

End Sub
 
You are :awesome:

This works just wanted to clarify we doubts:
What does - Resize(.Rows.Count - 1) - this do?
Is it possible to copy the format along with the data?

Everything else works supercool :)
 
What does - Resize(.Rows.Count - 1) - this do?
Click to expand...
range except top row/header.

Is it possible to copy the format along with the data?
Click to expand...
in loop2 replace it
Code: 
With ws.Cells(1, 1).CurrentRegion
                    .Offset(1).Resize(.Rows.Count - 1).Copy
                    ThisWorkbook.Sheets(1).Cells(lrow, 1).PasteSpecial xlPasteAllUsingSourceTheme
                    ThisWorkbook.Sheets(1).Cells(lrow, 1).PasteSpecial xlPasteValues
                    Application.CutCopyMode = False: lrow = lrow + .Rows.Count - 1
                End With

in loop1

Code: 
[dest].CurrentRegion.Copy
            ThisWorkbook.Sheets(1).Cells(lrow, 1).PasteSpecial xlPasteAllUsingSourceTheme
            ThisWorkbook.Sheets(1).Cells(lrow, 1).PasteSpecial xlPasteValues

in simple term added a extra line with PasteSpecial Values
 
So, removing (-1) from it will copy the first row/header?
Actually I removed (-1) and it dint make a difference, but thats fine.

If you dont mind, what if I have to exclude the first column in it.

loop1 still gives error so I am happy with loop 2. Thank you so much.
Have a good week ahead :)
 
Last edited:
You explained well. Nice one. This helped me with my question on excluding 1st col too.

Thanks again on this one. Will see you soon on new query :) ;)
 
Hi here, Deepak :)

Can this below be done for consolidation code above?

In this code, if I have to cut-paste the data consolidated from Sheet1 to Sheet2 and rename it with current date? OR

If there can be a messagebox asking from which row and column the data has to be copied?

Happy New Year To You :)
 
Check it..


Code: 
Option Explicit
Sub loop2()
Dim fol As String, wb As String, mywb As Workbook, ws As Worksheet, lrow As Integer
Dim x As String: x = Format(Date, "DDMMYYYY")
Application.ScreenUpdating = False

With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False:    .Show
    On Error Resume Next: fol = .SelectedItems(1): Err.Clear: On Error GoTo 0
End With

fol = fol & "\":    wb = Dir(fol & "*.xls*")
If wb = "" Then Exit Sub

ThisWorkbook.Sheets.Add().Name = x

lrow = 2
    Do While wb <> ""
    If Not wb <> ThisWorkbook.Name Then GoTo n
        Set mywb = Workbooks.Open(fol & wb)
            For Each ws In mywb.Worksheets
                With ws.Cells(1, 1).CurrentRegion
                    .Offset(1).Resize(.Rows.Count - 1).Copy
                    ThisWorkbook.Sheets(x).Cells(lrow, 1).PasteSpecial xlPasteValues
                    Application.CutCopyMode = False: lrow = lrow + .Rows.Count - 1
                End With
            Next
        mywb.Close 0
n:  wb = Dir
    Loop

Application.ScreenUpdating = True

End Sub
 
I will try this and also work on Input box method.
Actually with input box I will avoid creating multiple sheets and Input box will ask me to select the range I want to copy.
 
You must log in or register to reply here.
Back
Top