Forum Discussion
VBA to compile multiple differently named worksheets
Hi,
I have code compiled from a few sources with the aim to compile 230 individual spreadsheets in to one long one. (I have tried a query and as the tabs are all named differently this does not seem to work.)
So far, this code copies the data from the first workbook then the second below it but then copies the data over the top for 229 workbooks rather than below or just stops. Can anyone point out where I am going wrong?
I know I need to recalculate the end of the target for each loop but don't know how.
Option Explicit
Const FOLDER_PATH = "\\mydata\workfiles\" 'REMEMBER END BACKSLASH
Sub ImportWorksheets()
'=============================================
'Process all Excel files in specified folder
'=============================================
Dim sFile As String 'file to process
Dim wsTarget As Worksheet
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim rowTarget As Long 'output row
rowTarget = 2
'check the folder exists
If Not FileFolderExists(FOLDER_PATH) Then
MsgBox "Specified folder does not exist, exiting!"
Exit Sub
End If
'reset application settings in event of error
On Error GoTo errHandler
Application.ScreenUpdating = True
Application.DisplayAlerts = False
'set up the target worksheet
Set wsTarget = Sheets("Sheet1")
'loop through the Excel files in the folder
sFile = Dir(FOLDER_PATH & "*.xls*")
Do Until sFile = ""
'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
Set wsSource = wbSource.Worksheets(1) 'EDIT IF NECESSARY
With wsTarget
Dim lrow1 As Long
Dim lrow2 As Long
lrow1 = wsSource.Cells(Rows.Count, 1).End(xlUp).Row 'change the "1" to the column # of the beginning of the data set (defult is column A)
lrow2 = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row + 1 'change the "1" to the column # of the beginning of the data set (defult is column A)
wsSource.Range("A2:AF" & lrow1).Copy Destination:=wsTarget.Range("A" & lrow2) ' Change the range to start cell of your data and the end column of your data (defult A2:K endrow of data)
End With
'close the source workbook, increment the output row and get the next file
wbSource.Close SaveChanges:=False
rowTarget = rowTarget + 1
sFile = Dir()
Loop
errHandler:
On Error Resume Next
Application.ScreenUpdating = True
'tidy up
Set wsSource = Nothing
Set wbSource = Nothing
Set wsTarget = Nothing
End Sub
Private Function FileFolderExists(strPath As String) As Boolean
If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function
Line #47 in your code is
lrow2 = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row + 1 'change the "1" to the column # of the beginning of the data set (defult is column A)
This calculates the last used row in column A (column #1) of the target sheet and adds 1.
If column A is empty, this will result in lrow2 = 2 each time.
You'll need to specify a column that is guaranteed to be populated. Let's say that column D (column #4) is always filled. Change line #47 to
lrow2 = wsTarget.Cells(Rows.Count, 4).End(xlUp).Row + 1
- LindsyCopper ContributorThat seem to break the code, the code loops open and close but nothing is pasted after the first loop. This may be being made more difficult by the fact on the MI it is coping and pasting Ctrl A highlights 50,000 rows most of which are blank, and this is the same for all 230 workbooks I am trying to append.