VBA to compile multiple differently named worksheets

[Lindsy]

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

[#2]

@Lindsy 

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

[#3]

That 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.