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

Merge All worksheet from multiple workbooks to one workbook

A

anshul.malhotra

Member
Hi All,

I am looking for help as I am not a pro in VBA but have googled many code and fix my task, however this it is not helping me;

I want to merge 184 excel workbook, where each workbook has 3-5 worksheet, with Workbook name stamp in last column and Sheet tab name in next column following workbook name. But the below code is working on only one worksheet not all and also I am not able to add worksheet name from where the data has been copied from.

below is the code I am using

Code: 
Sub Merge_with_Col_added()
Dim fn, ws As Worksheet, e, flg As Boolean, LastR As Range, wsName As String
fn = Application.GetOpenFilename("Excel(*.xls*),*.xls*", MultiSelect:=True)
If Not IsArray(fn) Then Exit Sub
Set ws = ActiveWorkbook.Sheets.Add
ws.Name = "Combined"
Set ws = ActiveWorkbook.Sheets("Combined")
Application.ScreenUpdating = False
ws.Cells.Clear
For Each e In fn
With Workbooks.Open(e)
With .Sheets(1)
wsName = .Name
If Not flg Then
  .Rows(1).Copy ws.Cells(1)
ws.Columns(1).Insert
ws.Cells(1).Value = "Sheet name"
flg = True
End If
Set LastR = ws.Cells(Rows.Count, 2).End(xlUp)(2)
With .Range("a1").CurrentRegion
With .Resize(.Rows.Count - 1).Offset(1)
.Copy LastR
LastR(, 0).Resize(.Rows.Count).Value = CreateObject("Scripting.FileSystemObject").GetBasename(e)
End With
End With
End With
.Close False
End With
Next
ws.Range("a1").CurrentRegion.Columns.AutoFit
Application.ScreenUpdating = True
Set ws = Nothing
End Sub

Thanks in advance

Anshul
 
Last edited by a moderator:
First, for dealing with all sheets in each file, try:
Code: 
Sub Merge_with_Col_added()
Dim fn, ws As Worksheet, e, flg As Boolean, LastR As Range, wsName As String
fn = Application.GetOpenFilename("Excel(*.xls*),*.xls*", MultiSelect:=True)
If Not IsArray(fn) Then Exit Sub
Set ws = ActiveWorkbook.Sheets.Add
ws.Name = "Combined"
Set ws = ActiveWorkbook.Sheets("Combined")
Application.ScreenUpdating = False
ws.Cells.Clear
For Each e In fn
  With Workbooks.Open(e)
    For Each sht In .Sheets
      With sht
        wsName = .Name
        If Not flg Then
          .Rows(1).Copy ws.Cells(1)
          ws.Columns(1).Insert
          ws.Cells(1).Value = "Sheet name"
          flg = True
        End If
        Set LastR = ws.Cells(Rows.Count, 2).End(xlUp)(2)
        With .Range("a1").CurrentRegion
          With .Resize(.Rows.Count - 1).Offset(1)
            .Copy LastR
            LastR(, 0).Resize(.Rows.Count).Value = CreateObject("Scripting.FileSystemObject").GetBasename(e)
          End With    '.Resize(.Rows.Count - 1).Offset(1)
        End With    '.Range("a1").CurrentRegion
      End With    'sht
    Next sht
    .Close False
  End With    'Workbooks.Open(e)
Next    'e
ws.Range("a1").CurrentRegion.Columns.AutoFit
Application.ScreenUpdating = True
Set ws = Nothing
End Sub
 
p45cal said:
First, for dealing with all sheets in each file, try:
Code: 
Sub Merge_with_Col_added()
Dim fn, ws As Worksheet, e, flg As Boolean, LastR As Range, wsName As String
fn = Application.GetOpenFilename("Excel(*.xls*),*.xls*", MultiSelect:=True)
If Not IsArray(fn) Then Exit Sub
Set ws = ActiveWorkbook.Sheets.Add
ws.Name = "Combined"
Set ws = ActiveWorkbook.Sheets("Combined")
Application.ScreenUpdating = False
ws.Cells.Clear
For Each e In fn
  With Workbooks.Open(e)
    For Each sht In .Sheets
      With sht
        wsName = .Name
        If Not flg Then
          .Rows(1).Copy ws.Cells(1)
          ws.Columns(1).Insert
          ws.Cells(1).Value = "Sheet name"
          flg = True
        End If
        Set LastR = ws.Cells(Rows.Count, 2).End(xlUp)(2)
        With .Range("a1").CurrentRegion
          With .Resize(.Rows.Count - 1).Offset(1)
            .Copy LastR
            LastR(, 0).Resize(.Rows.Count).Value = CreateObject("Scripting.FileSystemObject").GetBasename(e)
          End With    '.Resize(.Rows.Count - 1).Offset(1)
        End With    '.Range("a1").CurrentRegion
      End With    'sht
    Next sht
    .Close False
  End With    'Workbooks.Open(e)
Next    'e
ws.Range("a1").CurrentRegion.Columns.AutoFit
Application.ScreenUpdating = True
Set ws = Nothing
End Sub
Click to expand...

Thanks p45cal... this work for multiple sheet tabs now, can you help me getting the sheet tab name too next to workbook name in column B
 
Code: 
Sub Merge_with_Col_added()
Dim fn, ws As Worksheet, e, flg As Boolean, LastR As Range, wsName As String
fn = Application.GetOpenFilename("Excel(*.xls*),*.xls*", MultiSelect:=True)
If Not IsArray(fn) Then Exit Sub
Set ws = ActiveWorkbook.Sheets.Add
ws.Name = "Combined"
Set ws = ActiveWorkbook.Sheets("Combined")
Application.ScreenUpdating = False
ws.Cells.Clear
For Each e In fn
  With Workbooks.Open(e)
    For Each sht In .Sheets
      With sht
        wsName = .Name
        If Not flg Then
          .Rows(1).Copy ws.Cells(1)
          ws.Columns(1).Resize(, 2).Insert
          ws.Cells(1, 1).Value = "Workbook"
          ws.Cells(1, 2).Value = "Sheet name"
          flg = True
        End If
        Set LastR = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 2)
        Application.Goto LastR
        With .Range("a1").CurrentRegion
          With .Resize(.Rows.Count - 1).Offset(1)
            .Copy LastR
            'LastR(, 0).Resize(.Rows.Count).Value = CreateObject("Scripting.FileSystemObject").GetBasename(e)
            LastR.Offset(, -2).Resize(.Rows.Count).Value = CreateObject("Scripting.FileSystemObject").GetBasename(e)
            LastR.Offset(, -1).Resize(.Rows.Count).Value = sht.Name
          End With    '.Resize(.Rows.Count - 1).Offset(1)
        End With    '.Range("a1").CurrentRegion
      End With    'sht
    Next sht
    .Close False
  End With    'Workbooks.Open(e)
Next    'e
ws.Range("a1").CurrentRegion.Columns.AutoFit
Application.ScreenUpdating = True
Set ws = Nothing
End Sub
 
T
p45cal said:
Code: 
Sub Merge_with_Col_added()
Dim fn, ws As Worksheet, e, flg As Boolean, LastR As Range, wsName As String
fn = Application.GetOpenFilename("Excel(*.xls*),*.xls*", MultiSelect:=True)
If Not IsArray(fn) Then Exit Sub
Set ws = ActiveWorkbook.Sheets.Add
ws.Name = "Combined"
Set ws = ActiveWorkbook.Sheets("Combined")
Application.ScreenUpdating = False
ws.Cells.Clear
For Each e In fn
  With Workbooks.Open(e)
    For Each sht In .Sheets
      With sht
        wsName = .Name
        If Not flg Then
          .Rows(1).Copy ws.Cells(1)
          ws.Columns(1).Resize(, 2).Insert
          ws.Cells(1, 1).Value = "Workbook"
          ws.Cells(1, 2).Value = "Sheet name"
          flg = True
        End If
        Set LastR = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 2)
        Application.Goto LastR
        With .Range("a1").CurrentRegion
          With .Resize(.Rows.Count - 1).Offset(1)
            .Copy LastR
            'LastR(, 0).Resize(.Rows.Count).Value = CreateObject("Scripting.FileSystemObject").GetBasename(e)
            LastR.Offset(, -2).Resize(.Rows.Count).Value = CreateObject("Scripting.FileSystemObject").GetBasename(e)
            LastR.Offset(, -1).Resize(.Rows.Count).Value = sht.Name
          End With    '.Resize(.Rows.Count - 1).Offset(1)
        End With    '.Range("a1").CurrentRegion
      End With    'sht
    Next sht
    .Close False
  End With    'Workbooks.Open(e)
Next    'e
ws.Range("a1").CurrentRegion.Columns.AutoFit
Application.ScreenUpdating = True
Set ws = Nothing
End Sub
Click to expand...


Thanks a lot for your help...
 
You must log in or register to reply here.
Back
Top