Consolidate selected worksheets into new one and format as table

Good morning VBA'ers,

I have an excel workbook where there are 9 worksheets of which 6 contain data in Columns A:CP and should always remain the same; however, the Row depths will vary depending on each.

What I would like to do at a click of a button is to consolidate the 6 RED worksheets into ONE worksheet called "Consolidate" (ignoring the other worksheets) but ensure that any blank cells in Column A of the wroksheets do not prevent the macro from running....so my newbie logic says to me that perhaps first read the columns the rows but I'm guessing you will know best. Also would be great to be able to amend the code to expand the column selection should the need arise in the future.

Following that it would be great if the macro would then format the consolidation tab data into a table of sorts whereby the top line is Frozen, a filter added and some table format (colour) of any description is added.

I have made an attempt (macro) which works pretty well but it grabs data from every tab and I'm not knowledgeable enough to tweak this "borrowed" code

Thanking everyone in advance.

Option Explicit

Sub GripSheets()

Dim cs As Worksheet, ws As Worksheet, LR As Long, NR As Long

If Not Evaluate("ISREF(Consolidate!A2)") Then _
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Consolidate"

Set cs = Sheets("Consolidate")
cs.Cells.ClearContents
NR = 1

    For Each ws In Worksheets
        If ws.Name <> "Consolidate" Then
            ws.Activate
            LR = Range("A" & Rows.Count).End(xlUp).Row
            Range("A2:CP" & LR).Copy
            cs.Range("A" & NR).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            NR = cs.Range("A" & Rows.Count).End(xlUp).Row + 1
        End If
        
    Next ws
    Sheets("Sam").Select
        Rows("1:1").Select
            Application.CutCopyMode = False
        Selection.Copy
            Sheets("Consolidate").Select
            Rows("1:1").Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

cs.Activate
Range("A1").Select

    With ActiveSheet.ListObjects.Add(xlSrcRange, ActiveSheet.Range("A1").CurrentRegion, , xlYes)
    .Name = "Table1"
    .TableStyle = "TableStyleMedium9"
    
    End With
End Sub

Hi, Mad-Dog,

Your post does not comply with Rule 3 of our Forum RULES. Use code tags around code.

Posting code between [CODE] [/CODE] tags makes your code much easier to read and copy for testing, it also maintains VBA formatting.

Highlight your code and click the # icon at the top of your post window. More information about these and other tags can be found here



(This thread should receive no further responses until this moderation request is fulfilled, as per Forum Rule 7)

Ciao,
Holger

Hi, Mad-Dog,

from what I suggest I guess you may try (please adapt the names of the worksheets to suit, I assumed all to be consildated start with RED):

Sub GripSheets()

Dim cs As Worksheet, ws As Worksheet, LR As Long, NR As Long

If Not Evaluate("ISREF(Consolidate!A2)") Then _
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Consolidate"

Set cs = Sheets("Consolidate")
cs.Range("A2:CP" & Rows.Count).ClearContents

For Each ws In Worksheets
  If ws.Name <> "Consolidate" And UCase(Left(ws.Name, 3)) = "RED" Then
    LR = ws.Range("A" & Rows.Count).End(xlUp).Row
    NR = cs.Range("A" & Rows.Count).End(xlUp).Row + 1
    ws.Range("A2:CP" & LR).Copy
    cs.Range("A" & NR).PasteSpecial xlPasteValues
    Application.CutCopyMode = False
  End If
Next ws

With cs
  .Range("A1").Select
  With .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion, , xlYes)
    .Name = "Table1"
    .TableStyle = "TableStyleMedium9"
  End With
End With
End Sub

Again this is what I figure out without seeing the data in the workbook, there may be a better way to do what you would like to get.

Ciao,
Holger

Hi, Mad-Dog,

of which 6 contain data

Sam, Chris, Emraz, Katy, Sophie, Monica, Kathrin

make up a count of 7 to me

Sub GripSheets_2()

Dim cs As Worksheet, ws As Worksheet, LR As Long, NR As Long

Const cstrLAST_COL As String = "CP"

If Not Evaluate("ISREF(Consolidate!A2)") Then _
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Consolidate"

Set cs = Sheets("Consolidate")
cs.Range("A2:" & cstrLAST_COL & Rows.Count).ClearContents

For Each ws In Worksheets
  Select Case ws.Name
    Case "Sam", "Chris", "Emraz", "Katy", "Sophie", "Monica", "Kathrin"
      LR = ws.Range("A" & Rows.Count).End(xlUp).Row
      NR = cs.Range("A" & Rows.Count).End(xlUp).Row + 1
      ws.Range("A2:" & cstrLAST_COL & LR).Copy
      cs.Range("A" & NR).PasteSpecial xlPasteValues
      Application.CutCopyMode = False
    Case Else
      'do nothing here
  End Select
Next ws

With cs
  .Range("A1").Select
  With .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion, , xlYes)
    .Name = "Table1"
    .TableStyle = "TableStyleMedium9"
  End With
End With
End Sub

The constant isnīt as dynamic as you may want it to be - I would need if the headings for the data wioll always be in the same row in order to check out the last used column via

lngLC = Cells(1, Columns.Count).End(xlToLeft).Column

Ciao,
Holger

Hi, Mad-Dog,

cs.Range("A2:" & cstrLAST_COL & Rows.Count).ClearContents

This line of code should delete all contents without the headers from the summary sheet - Iīm afraid I canīt get what you are askin gof rwith

Can we make it so that if the macro is run again it simply overwrites the current data "Consolidate" tab.

Due to maybe different amounts of data I would recommend to clear before simply overwriting and maybe leave older records which arenīt actual any more.

Can you please explain to me what you expect the code to do - I may be able to put that into a code-line for work?

Ciao,
Holger

Hi, Mad-Dog,

I forgot about the Table and worked for a normal range instead.

Please try:

Sub GripSheets_3()

Dim cs As Worksheet, ws As Worksheet, LR As Long, NR As Long

Const cstrLAST_COL As String = "CP"
Const cstrTABLE As String = "Table1"

If Not Evaluate("ISREF(Consolidate!A2)") Then _
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Consolidate"

Set cs = Sheets("Consolidate")
On Error Resume Next
cs.ListObjects(cstrTABLE).Unlist
On Error GoTo 0
cs.Range("A2").CurrentRegion.Offset(1, 0).Delete

For Each ws In Worksheets
  Select Case ws.Name
    Case "Sam", "Chris", "Emraz", "Katy", "Sophie", "Monica", "Kathrin"
      LR = ws.Range("A" & Rows.Count).End(xlUp).Row
      NR = cs.Range("A" & Rows.Count).End(xlUp).Row + 1
      ws.Range("A2:" & cstrLAST_COL & LR).Copy
      cs.Range("A" & NR).PasteSpecial xlPasteValues
      Application.CutCopyMode = False
    Case Else
      'do nothing here
  End Select
Next ws

With cs
  Application.Goto Reference:=.Range("A1"), Scroll:=True
  With .ListObjects.Add(xlSrcRange, .Range("A1").CurrentRegion, , xlYes)
    .Name = cstrTABLE
    .TableStyle = "TableStyleMedium9"
  End With
End With
End Sub

Ciao,
Holger