Merge/combine sheets based on their name

[coubs3]

Currently I have a workbook with about 15 tabs with 100s of rows each. I only want to combine 10. The code below works for me if I remove the 5 tabs I dont want but is there a way to adjust this to define the tabs I want to combine? Better yet a dialog box to pick which tabs?




Sub CombineWorksheetsIntoOne()
Application.ScreenUpdating = False
Dim wb As Workbook
Dim ws As Worksheet
Dim ms As Worksheet
Dim rng As Range
Dim colCount As Integer
Set wb = ActiveWorkbook
Set ms = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
ms.Name = "Main"
Set ws = wb.Worksheets(1)
colCount = ws.Cells(1, 255).End(xlToLeft).Column

With ms.Cells(1, 1).Resize(1, colCount)
.Value = ws.Cells(1, 1).Resize(1, colCount).Value
.Font.Bold = True
End With
For Each ws In wb.Worksheets
If ws.Index = wb.Worksheets.Count Then
Exit For
End If
Set rng = ws.Range(ws.Cells(2, 1), ws.Cells(65536, 1).End(xlUp).Resize(, colCount))
ms.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
Next ws
ms.Columns.AutoFit
Application.ScreenUpdating = True
End Sub

 

[HaHoBe]

Hi coubs3,

maybe like this

Sub MrE1221699_1613917()
'https://www.mrexcel.com/board/threads/merge-combine-sheets-based-on-their-name.1221699/
  Dim wb            As Workbook
  Dim ws            As Worksheet
  Dim wsMaster      As Worksheet
  Dim rngWork       As Range
  Dim lngLastCol      As Integer
  
  Application.ScreenUpdating = False
  Set wb = ActiveWorkbook
  Set wsMaster = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
  wsMaster.Name = "Main"
  Set ws = wb.Worksheets(1)
  lngLastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
  
  With wsMaster.Cells(1, lngLastCol)
    .Value = ws.Cells(1, lngLastCol).Value
    .Font.Bold = True
  End With
  
  For Each ws In wb.Worksheets
    Select Case ws.Name
      Case wsMaster.Name, "Not to copy1", "No way", "Do not copy"
        'no action on sheet for collecting data as well as the sheet names that
        'will be excluded
      Case Else
        lngLastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
        Set rngWork = ws.Range(ws.Cells(2, 1), ws.Cells(Rows.Count, 1).End(xlUp).Resize(, lngLastCol))
        wsMaster.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(rngWork.Rows.Count, rngWork.Columns.Count).Value = rngWork.Value
    End Select
  Next ws
  
  wsMaster.Columns.AutoFit
  Set rngWork = Nothing
  Set wsMaster = Nothing
  Set wb = Nothing
  
  Application.ScreenUpdating = True

End Sub

Ciao,
Holger

 

[coubs3]

One issue I have with this from the original code is it doesn't maintain the first row as headers. This is also asking me to define the sheets to "exclude". Ideally I would still like a solution of a dialog box to let me select the tabs to combine while maintaining the first row as headers.

 

[HaHoBe]

Hi coubs3,

you're right - my bad.

Instead of

  With wsMaster.Cells(1, lngLastCol)
    .Value = ws.Cells(1, lngLastCol).Value
    .Font.Bold = True
  End With

it should be

  With wsMaster.Cells(1, 1).Resize(1, lngLastCol)
    .Value = ws.Cells(1, 1).Resize(1, lngLastCol).Value
    .Font.Bold = True
  End With

AFAIK you would need to add an UserForm to get that dialogue. Insert a UserForm, add listbox to it as well as two commandbuttons. I usually rename the buttons to (Name) cmdCancel and Caption Cancel as well as cmdOK and OK. You would need to change the names in the procedures cmdCancel, cmdOK and ListBox1 to suit to setting, they will not be updated automaticly. Place this code behind the UserForm (it's from my setup):

Private Sub cmdCancel_Click()
  Unload Me 
End Sub

Private Sub cmdOK_Click()
  Dim lngCounter      As Integer
  Dim wsWork          As Worksheet
  Dim wsMaster        As Worksheet
  Dim blnHeader       As Boolean
  Dim rngWork         As Range
 
  Const cstrMAIN As String = "Main"
 
  If Not Evaluate("ISREF('" & cstrMAIN & "'!A1)") Then
    Set wsMaster = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    wsMaster.Name = cstrMAIN
    blnHeader = True
  Else
    Set wsMaster = Worksheets(cstrMAIN)
    wsMaster.UsedRange.ClearContents
    blnHeader = True
  End If
 
  For lngCounter = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(lngCounter) Then
      Set wsWork = Worksheets(ListBox1.List(lngCounter))
      If blnHeader Then
        With wsMaster.Cells(1, 1).Resize(1, wsWork.UsedRange.Columns.Count)
          .Value = wsWork.UsedRange.Rows(1).Value
          .Font.Bold = True
          blnHeader = False
        End With
      End If
      Set rngWork = wsWork.UsedRange.Offset(1)
      wsMaster.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(rngWork.Rows.Count, rngWork.Columns.Count).Value = rngWork.Value
    End If
  Next lngCounter
 
  Set rngWork = Nothing
  Set wsWork = Nothing
  Set wsMaster = Nothing
 
  Unload Me

End Sub

Private Sub ListBox1_Change()
  Dim lngCounter      As Long
  Dim lngSel          As Long
 
  For lngCounter = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(lngCounter) Then
      lngSel = lngSel + 1
      cmdOK.Enabled = lngSel > 1
    End If
  Next lngCounter

End Sub

Private Sub UserForm_Initialize()
'https://www.mrexcel.com/board/threads/merge-combine-sheets-based-on-their-name.1221699
  Dim ws    As Worksheet
 
  With ListBox1
    .Clear
    .MultiSelect = fmMultiSelectExtended
    .ListStyle = fmListStyleOption
  End With
 
  For Each ws In ActiveWorkbook.Worksheets
    If UCase(ws.Name) <> "MAIN" Then
      ListBox1.AddItem ws.Name
    End If
  Next ws
 
  If ListBox1.ListCount = 1 Then
    ListBox1.ListIndex = 0
  End If
  cmdOK.Enabled = False

End Sub

Place this in a standard module and maybe add a shortcut:

Sub ShowDialogue()

  UserForm1.Show    'change name of UserForm to suit

End Sub

You might need to hold the CTRL-Button to make multiple choices.

Ciao,
Holger

 

[coubs3]

Thank you! Took me a bit to figure out the userform stuff as I have never used one but this works. Just to confirm as well you do have to hold ctrl to make multiple selections.

 

[coubs3]

Thank you! Took me a bit to figure out the userform stuff as I have never used one but this works. Just to confirm as well you do have to hold ctrl to make multiple selections.

 

[HaHoBe]

Hi coubs3,

is this what you had in mind?

A word on working with UserForms and Controls: this is just a small sample. If you have more controls it would be better to name them. And you should do this directlly after inserting the controls because if you double-click on the control you would be led behind the UserForm to a procedure showing the Control-Name (this will not be updated if you change the name of the control later on).

Ciao,
Holger

 

[coubs3]

Sorry. One more request, in the original code to combine. Is it possible to add something that would ignore filters on the tabs to make sure I get every entry in the Main summary tab?

 

[HaHoBe]

Hi coubs3,

any Autofilter would be ignored as you would have to specify to work with SpecialCells(xlCellTypeVisible) to get information only from entires of the filtered list. Or you could check if a Filter is set and deactivate it prior to copying the contents.

Ciao,
Holger

 

[coubs3]

Thank you again. This works wonderfully.