consolidating multiple wkbks as wkshts

[Jon von der Heyden]

Hi,

I have two folders, each contain 164 workbooks. All workbooks are identical in structure and I'd like to consolidate into one workbook as multiple worksheets so that I can do all the necessary summaries.

Is it possible to pick up the lot and drop them into one workbook?

Cheers,
Jon

 

[smozgur]

Hi Jon,

Following code uses folder path as variable - that you need to assign according to your workbooks path - and copies first worksheet from each workbook into a single workbook and rename the worksheets as their parent's name (source workbook name).

Open a new workbook then goto VBA (Alt+F11), insert a new Module (Insert->Module) and copy&paste following code into this new module that will be displayed in the right pane.

Sub CombineWorkbooks()
Dim fso As Object
Dim fld As Object
Dim fil As Object
Dim src As Workbook
Dim wrk As Workbook
Dim sht As Worksheet
Dim fldPath As String

  '*******CHANGE FOLLOWING BY USING YOUR PATH*******
  fldPath = "E:\MyWorkbooks\"
  '**************************************************

  On Error GoTo ErrHandler
  
  'Create FileSystemObject - We will use FSO to handle files
  Set fso = CreateObject("Scripting.FileSystemObject")
  'Folder contains workbooks
  Set fld = fso.getfolder(fldPath)
  
  'Create New Workbook
  Set wrk = Application.Workbooks.Add
  'Remove empty worksheets - except one
  Application.DisplayAlerts = False
  Do Until wrk.Worksheets.Count = 1
    DoEvents
    wrk.Worksheets(1).Delete
  Loop
  
  Application.ScreenUpdating = False
  'Loop through files in folder
  For Each fil In fld.Files
    'Execute only excel files
    If fil.Type = "Microsoft Excel Worksheet" Then
      'Open workbook
      Set src = Application.Workbooks.Open(fil.Path)
      'Copy first worksheet to the new excel workbook - as the last worksheet
      src.Worksheets(1).Copy After:=wrk.Worksheets(wrk.Worksheets.Count)
      Set sht = ActiveSheet
      'Rename the copied worksheet as parent workbook name
      sht.Name = src.Name
      'Close the source workbook
      src.Close False
    End If
  Next fil
  
  'Delete the first empty worksheet
  wrk.Worksheets(1).Delete

ErrHandler:
  If Err Then
    MsgBox Err.Number & "-" & Err.Description, vbOKOnly + vbExclamation, "Error"
  End If
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

I hope it helps.

 

[Jon von der Heyden]

It's running now, I imagine it'll take a little while.

Thanks a trillion, you've saved me hours!!!!

 

[smozgur]

... you've saved me hours!!!!

Glad to hear that!