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,

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]

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]

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]

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

 

[HaHoBe]

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]

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]

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]

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]

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!