# Merge/combine sheets based on their name



## coubs3 (Nov 9, 2022)

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 (Nov 9, 2022)

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 (Nov 9, 2022)

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 (Nov 10, 2022)

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 (Nov 10, 2022)

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 (Nov 10, 2022)

coubs3 said:


> 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 (Nov 10, 2022)

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 (Nov 10, 2022)

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 (Nov 10, 2022)

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 (Nov 10, 2022)

Thank you again.   This works wonderfully.


----------



## coubs3 (Nov 9, 2022)

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 (Nov 11, 2022)

Hi coubs3,

you should add the codeline


```
If wsMaster.AutoFilterMode Then wsMaster.AutoFilterMode = False
```

to test for an AutoFilter and turn it off before copying. I'm sorry I was wrong with my informations in #9-

Holger


----------



## coubs3 (Monday at 11:05 AM)

This is still working great for me but I need it to retain the original formatting of the text being copied over.   I have strikethroughs and red font that is not being carried over.  is this possible?


----------



## HaHoBe (Monday at 11:19 AM)

Hi coubs,

instead of codeline


```
wsMaster.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(rngWork.Rows.Count, rngWork.Columns.Count).Value = rngWork.Value
```


use


```
rngWork.Copy wsMaster.Cells(Rows.Count, 1).End(xlUp).Offset(1)
          Application.CutCopyMode = False
```


The first codeline just copies over the values, the second copies values and formats as well.

The whole code may look like


```
Sub MrE1221699_1700914()
'https://www.mrexcel.com/board/threads/merge-combine-sheets-based-on-their-name.1221699/
'Update: 20230109
'Reason: changed from only transferring values to copy values and formats

  Dim wb            As Workbook
  Dim ws            As Worksheet
  Dim wsMaster      As Worksheet
  Dim rngWork       As Range
  Dim lngLastCol    As Long
  
  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, 1).Resize(1, lngLastCol)
    .Value = ws.Cells(1, 1).Resize(1, lngLastCol).Value
    .Font.Bold = True
  End With
  If ActiveWindow.SelectedSheets.Count > 1 Then
  
    For Each ws In ActiveWindow.SelectedSheets
  '    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))
'''          '/// copy over just the values
'''          wsMaster.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(rngWork.Rows.Count, rngWork.Columns.Count).Value = rngWork.Value
          '/// copy over values and formats
          rngWork.Copy wsMaster.Cells(Rows.Count, 1).End(xlUp).Offset(1)
          Application.CutCopyMode = False
  '    End Select
    Next ws
    wsMaster.Columns.AutoFit
  End If
  Set rngWork = Nothing
  Set wsMaster = Nothing
  Set wb = Nothing
  
  Application.ScreenUpdating = True

End Sub
```

Ciao,
Holger


----------



## coubs3 (Monday at 11:49 AM)

That does not seem to work.   I still get the same results.


----------



## HaHoBe (Monday at 1:45 PM)

Hi coubs3,

how do you start the procedure? I had to change the code to make it work, I started _MrE1221699_1700914_mod_ from the IDE and formatting was transferred:


```
Sub MrE1221699_1700914_mod()
'https://www.mrexcel.com/board/threads/merge-combine-sheets-based-on-their-name.1221699/
'Update: 20230109
'Reason: changed from only transferring values to copy values and formats

  Dim wb            As Workbook
  Dim ws            As Worksheet
  Dim wsMaster      As Worksheet
  Dim rngWork       As Range
  Dim lngLastCol    As Long
  
  Const cstrColl As String = "Main"
  
  Application.ScreenUpdating = False
  Set wb = ActiveWorkbook
  If Evaluate("ISREF('" & cstrColl & "'!A1)") Then
    Set wsMaster = Worksheets(cstrColl)
    wsMaster.UsedRange.Delete
  Else
    Set wsMaster = wb.Worksheets.Add(after:=wb.Worksheets(wb.Worksheets.Count))
    wsMaster.Name = "Main"
  End If
  Set ws = wb.Worksheets(1)
  lngLastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
  
  With wsMaster.Cells(1, 1).Resize(1, lngLastCol)
    .Value = ws.Cells(1, 1).Resize(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))
        '/// copy over values and formats
        rngWork.Copy wsMaster.Cells(Rows.Count, 1).End(xlUp).Offset(1)
        Application.CutCopyMode = False
    End Select
  Next ws
  wsMaster.Columns.AutoFit
  
  Set rngWork = Nothing
  Set wsMaster = Nothing
  Set wb = Nothing
  
  Application.ScreenUpdating = True

End Sub
```

Holger


----------



## coubs3 (Wednesday at 10:25 AM)

I have ran it straight from the IDE and kicked it off from a button I created.   Either way the formatting is not retained.


----------



## jdellasala (Wednesday at 10:51 AM)

I hope you're aware that you can open a workbook (unopened or current), get a list of all the worksheets, and then append (pile the selected sheets one on top of another) with a few clicks using Power Query. Just saying, the interface is a LOT better than the VBA Editor, there's a LOT less coding - test - fix - repeat, and a LOT fewer errors. VBA is NOT the solution here, for sure!


----------



## coubs3 (Wednesday at 12:32 PM)

I am aware.   I have tried power query and for whatever reason it says it pulls all the rows but then over half the rows are blank.  I also have to do this so often that the effort to set up a VBA upfront is worth it to me.


----------



## jdellasala (Wednesday at 1:27 PM)

coubs3 said:


> I am aware.   I have tried power query and for whatever reason it says it pulls all the rows but then over half the rows are blank.  I also have to do this so often that the effort to set up a VBA upfront is worth it to me.


There are plenty of ways to deal with that. Before I learned PQ, I was dealing with a database of over 350K smartphones and four carriers. It would take a day to reconcile the database against one of the carrier's data. After a few hours with PQ, it took less than an hour. PQ is worth learning! I recommend YouTube playlists *here* and *here*. The playlists are long, but there's a good chance only a few are needed. I prefer the latter playlist because before and after example files are provided. And, of course, there's plenty of talent here. Post some data, I'm pretty sure it will be worth it!


----------

