Copy, paste and loop into multiple sheets

[Dummy Excel]

Hi All,
I need some help in creating a macro where it opens 20files one at a time from a folder and copies the contents into a blank sheet. When it opens the 2nd file upto 20, it copies from row 2 down (dont need the header again) and appends to the previous data. From files 21 to 40 it does the same thing as 1 to 20 although pastes into sheet 2. THis continues in 20 file blocks until all the files are done.


another way of putting it is:
1) at any blank workbook run macro
2) macro opens first file in C:\temp
3) macro copies data (including header) from the opened file from sheet 1 and pasts into blank workbook then closes the opened file
4) macro opens second file copies data (except for header) and pastes into the bottom of the data of the blank workbook
5) macro does step for upto file number 20
6) macro opens 21st file and copies data including header to sheet 2
7) macro opens files from 22 to 40 and copies data except for header into sheet 2

macro basically opens 20 files and pastes the contests in a sheet, next 20 files into another sheet and so on till all files have been copied.

really appreciate your help

 

[rjwebgraphix]

Try this and see how it works for you. I snagged the file loop from ozgrid, but modified it with a little of my own flavor. There's an optional line that is commented out. If you want to specify a file name or can even use wildcards to define a list of files. IE: myfile*.xls.

It's set up so files 1-20 go to sheet 1, files 21-40 go to sheet 2, files 41 and up will go to sheet3.... although I have not tested any except Sheet1, so you'll have to test that.

There might be better ways to do some things, but this works.

Option Explicit

Sub MergeFiles()
'Base on looping through files in a folder code from Ozgrid
'http://www.ozgrid.com/VBA/loop-through.htm

Dim lCount As Long
Dim wbDataBook As Workbook
Dim wbCodeBook As Workbook
Set wbCodeBook = ThisWorkbook

Dim FFolder As String
Dim FNameFilter As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

'Change path to suit
FFolder = "C:\temp"

'Optional Filter with Wildcard Just uncomment FName and change
'to your naming format.  Will do all files in folder otherwise.

'FNameFilter = "Book*.xls"

Dim c1 As Range, c2 As Range, rng As Range
Dim frDataBook As Long
Dim lrCodeBook As Long
Dim wsCodeBook As Worksheet
Dim lrDataBook As Long, lcDataBook As Long


With Application.FileSearch
    .NewSearch
    .LookIn = FFolder
    .FileType = msoFileTypeExcelWorkbooks
    'Optional filter with wildcard
    If FNameFilter <> "" Then
        .Filename = FNameFilter
    End If
        If .Execute > 0 Then 'Workbooks in folder
            For lCount = 1 To .FoundFiles.Count 'Loop through all
                'Open Workbook x and Set a Workbook variable to it
                
                Set wbDataBook = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
                
                'Set sheet to copy to.
                If lCount >= 1 And lCount <= 20 Then
                    Set wsCodeBook = Sheets("Sheet1")
                ElseIf lCount >= 21 And lCount <= 40 Then
                    Set wsCodeBook = Sheets("Sheet2")
                Else
                    Set wsCodeBook = Sheets("Sheet3")
                End If

                lrDataBook = Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row
                lcDataBook = Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, SearchDirection:=xlPrevious).Column
                On Error Resume Next
                    lrCodeBook = Workbooks(wbCodeBook.Name).Sheets(wsCodeBook.Name).Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row
                On Error GoTo 0
                If lrCodeBook = 0 Then
                    Set c1 = wbDataBook.ActiveSheet.Cells(1, "A")
                    Set c2 = wbDataBook.ActiveSheet.Cells(lrDataBook, lcDataBook)
                    Set rng = wbDataBook.ActiveSheet.Range(c1, c2)
                    rng.Copy Destination:=Workbooks(wbCodeBook.Name).Sheets(wsCodeBook.Name).Range("A1")
                Else
                    Set c1 = wbDataBook.ActiveSheet.Cells(2, "A")
                    Set c2 = wbDataBook.ActiveSheet.Cells(lrDataBook, lcDataBook)
                    Set rng = wbDataBook.ActiveSheet.Range(c1, c2)
                    rng.Copy Destination:=Workbooks(wbCodeBook.Name).Sheets(wsCodeBook.Name).Range("A" & lrCodeBook + 1)
                End If
                wbDataBook.Close SaveChanges:=False
            Next lCount
        End If
End With

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub

 

[Dummy Excel]

it crashes straight away on With Application.FileSearch

 

[rjwebgraphix]

Strange, that part came from ozgrid, I didn't write it. What version of excel are you running?

 

[rjwebgraphix]

Try this one instead. I didn't notice that the file loop didn't work on later versions of excel. Hopefully this works for you..

Note that it will loop through all *.xls? files. This should also cover the newer file extensions.

Sub MergeFiles2()
'Loop through files code for Excel07 based on
'http://en.allexperts.com/q/Excel-1059/2010/10/Excel-VBA-2007-Loop.htm

'   Declare the variables
Dim wbCodeBook As Workbook
Set wbCodeBook = ThisWorkbook

Dim FFolder As String
Dim FNameFilter As String
Dim wbDataBook As Workbook

'   Define the path to the folder containing the target files (change accordingly)
FFolder = "C:\temp\"
   
'   Call the first .xls file (change the file extension accordingly)
FNameFilter = Dir(FFolder & "*.xls?")
   
Dim c1 As Range, c2 As Range, rng As Range
Dim lrCodeBook As Long
Dim wsCodeBook As Worksheet
Dim lrDataBook As Long, lcDatabook As Long
Dim lCount As Long
'   Loop through each file in the folder
lCount = 0
Do While Len(FNameFilter) > 0
    Set wbDataBook = Workbooks.Open(Filename:=FFolder & FNameFilter)
     
            lCount = lCount + 1
            If lCount >= 1 And lCount <= 20 Then
                Set wsCodeBook = Sheets("Sheet1")
            ElseIf lCount >= 21 And lCount <= 40 Then
                Set wsCodeBook = Sheets("Sheet2")
            Else
                Set wsCodeBook = Sheets("Sheet3")
            End If

            lrDataBook = Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row
            lcDatabook = Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, SearchDirection:=xlPrevious).Column
            On Error Resume Next
                lrCodeBook = Workbooks(wbCodeBook.Name).Sheets(wsCodeBook.Name).Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row
            On Error GoTo 0
            If lrCodeBook = 0 Then
                Set c1 = wbDataBook.ActiveSheet.Cells(1, "A")
                Set c2 = wbDataBook.ActiveSheet.Cells(lrDataBook, lcDatabook)
                Set rng = wbDataBook.ActiveSheet.Range(c1, c2)
                rng.Copy Destination:=Workbooks(wbCodeBook.Name).Sheets(wsCodeBook.Name).Range("A1")
            Else
                Set c1 = wbDataBook.ActiveSheet.Cells(2, "A")
                Set c2 = wbDataBook.ActiveSheet.Cells(lrDataBook, lcDatabook)
                Set rng = wbDataBook.ActiveSheet.Range(c1, c2)
                rng.Copy Destination:=Workbooks(wbCodeBook.Name).Sheets(wsCodeBook.Name).Range("A" & lrCodeBook + 1)
            End If
    
'   Close the current file (change the setting for this argument accordingly)
    wbDataBook.Close savechanges:=False
'   Call the next file
    FNameFilter = Dir
Loop
MsgBox ("Process is completed"), vbInformation

End Sub

 

[rjwebgraphix]

Ignore the last code, found a problem with Sheets other than Sheet1.

Try this one....

Sub MergeFiles2()
'Loop through files code for Excel07 based on
'http://en.allexperts.com/q/Excel-1059/2010/10/Excel-VBA-2007-Loop.htm

'   Declare the variables
Dim wbCodeBook As Workbook
Set wbCodeBook = ThisWorkbook

Dim FFolder As String
Dim FNameFilter As String
Dim wbDataBook As Workbook

'   Define the path to the folder containing the target files (change accordingly)
FFolder = "C:\temp\"
   
'   Call the first .xls file (change the file extension accordingly)
FNameFilter = Dir(FFolder & "*.xls?")
   
Dim c1 As Range, c2 As Range, rng As Range
Dim lrCodeBook As Long
Dim wsCodeBook As Worksheet
Dim lrDataBook As Long, lcDatabook As Long
Dim lCount As Long
'   Loop through each file in the folder
lCount = 0
Do While Len(FNameFilter) > 0
    Set wbDataBook = Workbooks.Open(Filename:=FFolder & FNameFilter)
     
            lCount = lCount + 1
            If lCount >= 1 And lCount <= 20 Then
                Set wsCodeBook = Sheets("Sheet1")
            ElseIf lCount >= 21 And lCount <= 40 Then
                Set wsCodeBook = Sheets("Sheet2")
            Else
                Set wsCodeBook = Sheets("Sheet3")
            End If

            lrDataBook = Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row
            lcDatabook = Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, SearchDirection:=xlPrevious).Column
            
            If Workbooks(wbCodeBook.Name).Sheets(wsCodeBook.Name).Cells(1, "A") = "" Then
                Set c1 = wbDataBook.ActiveSheet.Cells(1, "A")
                Set c2 = wbDataBook.ActiveSheet.Cells(lrDataBook, lcDatabook)
                Set rng = wbDataBook.ActiveSheet.Range(c1, c2)
                rng.Copy Destination:=Workbooks(wbCodeBook.Name).Sheets(wsCodeBook.Name).Range("A1")
            Else
                lrCodeBook = Workbooks(wbCodeBook.Name).Sheets(wsCodeBook.Name).Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row
                Set c1 = wbDataBook.ActiveSheet.Cells(2, "A")
                Set c2 = wbDataBook.ActiveSheet.Cells(lrDataBook, lcDatabook)
                Set rng = wbDataBook.ActiveSheet.Range(c1, c2)
                rng.Copy Destination:=Workbooks(wbCodeBook.Name).Sheets(wsCodeBook.Name).Range("A" & lrCodeBook + 1)
            End If
    
'   Close the current file (change the setting for this argument accordingly)
    wbDataBook.Close savechanges:=False
'   Call the next file
    FNameFilter = Dir
Loop
MsgBox ("Process is completed"), vbInformation

End Sub

 

[Dummy Excel]

the macro works although I cant see where it is pasting the data as the workbook is still blank? in saying that though the macro crashes on the 8th file here

If Workbooks(wbCodeBook.Name).Sheets(wsCodeBook.Name).Cells(1, "A") = "" Then

 

[rjwebgraphix]

Bah! Had it working last night, but today it took a crap... Give me a bit, I'll figure out why.

 

[rjwebgraphix]

Try this one.... This code needs to be in the workbook you want to copy to. it's only been tested through 22 files, but should work for all.

Sub MergeFiles2()
'Loop through files code for Excel07 based on
'http://en.allexperts.com/q/Excel-1059/2010/10/Excel-VBA-2007-Loop.htm

'   Declare the variables
Dim wbCodeBook As Workbook
Set wbCodeBook = ThisWorkbook

Dim FFolder As String
Dim FNameFilter As String
Dim wbDataBook As Workbook

'   Define the path to the folder containing the target files (change accordingly)
FFolder = "C:\temp\"
   
'   Call the first .xls file (change the file extension accordingly)
FNameFilter = Dir(FFolder & "*.xls?")
   
Dim c1 As Range, c2 As Range, rng As Range
Dim lrCodeBook As Long
Dim wsCodeBook As Worksheet
Dim lrDataBook As Long, lcDatabook As Long
Dim lCount As Long
'   Loop through each file in the folder
lCount = 0
Do While Len(FNameFilter) > 0
    Set wbDataBook = Workbooks.Open(Filename:=FFolder & FNameFilter)
     
            lCount = lCount + 1
            If lCount >= 1 And lCount <= 20 Then
                Set wsCodeBook = wbCodeBook.Sheets("Sheet1")
            ElseIf lCount >= 21 And lCount <= 40 Then
                Set wsCodeBook = wbCodeBook.Sheets("Sheet2")
            Else
                Set wsCodeBook = wbCodeBook.Sheets("Sheet3")
            End If
            
            lrDataBook = Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row
            lcDatabook = Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, SearchDirection:=xlPrevious).Column

            If wsCodeBook.Cells(1, "A") = vbNullString Then
                Set c1 = ActiveSheet.Cells(1, "A")
                Set c2 = ActiveSheet.Cells(lrDataBook, lcDatabook)
                Set rng = ActiveSheet.Range(c1, c2)
                rng.Copy Destination:=wsCodeBook.Range("A1")
            Else
                lrCodeBook = wsCodeBook.Cells.Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row
                Set c1 = ActiveSheet.Cells(2, "A")
                Set c2 = ActiveSheet.Cells(lrDataBook, lcDatabook)
                Set rng = ActiveSheet.Range(c1, c2)
                rng.Copy Destination:=wsCodeBook.Range("A" & lrCodeBook + 1)
            End If
    
'   Close the current file (change the setting for this argument accordingly)
    wbDataBook.Close savechanges:=False
'   Call the next file
    FNameFilter = Dir
Loop
MsgBox ("Process is completed"), vbInformation

End Sub

 

[Dummy Excel]

so i saved a blank workbook as sam.xlsm, saved the above VB code.
ran the code and its still wont paste into sheet1.
It then crashed on the 21st file basically saying cant find sheet2