VBA Creating Named Tables in multiple sheets in new workbook

Davavo

Board Regular
Joined
Aug 3, 2019
Messages
76
Hi, i have some code that
a) filters data from the table in one sheet into a group of new sheets named by the filter value
b) creates a new workbook from these sheets

The script does the above. The additional code has no effect that i can see. It doesnt stop it working, it just doesnt do anything.

I am trying to stick some code in between that turns the data on the sheets into tables before it copies them to a separate workbook (and preserve the tables of course).
I am also trying to name the table according to the sheet name and then add the total rows.
I have the code for adding a table, naming it (not according to the sheet name) and adding the total rows working on a one sheet version. But on this multi sheet method i cant get it to do anything.

I am doing it while the sheets are still in the original workbook because i figure it might be easier than trying to turn the data into tables when it is a separate workbook, but if it is easier, i have no preference.


I will paste the code section followed by the whole code including the secretion, which i have marked.

I would really appreciate someone showing me how to do this. A little explanation would also be great as I am trying my best to figure out how it actually works.

Code:
'----------------------------------------------------------------------------------------------------------------------------------------------------------------------'Start of code section that does not work


'create named tables on each sheet with total rows


For Each ws In ThisWorkbook.Worksheets
        Select Case ws.Name
            Case "Dashboard", "Expenses", "CCRead", "INVRead"  'list the sheets NOT to be worked on
            Case Else
            
                
                With Workbooks("Expenses.xlsm")
                                                                        
                                                                       
                    LastRow = ws.Range("M" & Rows.Count).End(xlUp).Row
                    
                    Range("A1:M20").Select
                    
                    'Range("A" & Lastrow, "M" & Lastrow).Select
                    
                    .ListObjects.Add(1, .Cells(1).CurrentRegion, , 1).Name = "TCCRecords" & ActiveSheet.Name
                    Columns("K").ColumnWidth = 25
                    


Set listob = ws.ListObjects(1)
                    
                    listob.ShowTotals = True
                                    
                                    
                                With ws.ListObjects("TCCRecords" & ActiveSheet.Name)
                                    .ListColumns("Value Excluding VAT £").TotalsCalculation = xlTotalsCalculationSum
                                    .ListColumns("VAT Value £").TotalsCalculation = xlTotalsCalculationSum
                                    .ListColumns("Total  Value £").TotalsCalculation = xlTotalsCalculationSum
                                    .ListColumns("Cost Centre").TotalsCalculation = xlTotalsCalculationNone
                                    
                                    Range("A1").Select
                                
                                
                                End With


                End With
        End Select


    Next
    
'end of code section that does not work
'------------------------------------------------------------------------------------------------------------------------------------------------------------------------

Full code ......


Code:
Sub NewNamedWorkbook()

Dim NewName As String
Dim LastRow As Long
Dim strFile As String
Dim listob As ListObject
       
    If MsgBox("Filter range to a new workbook?" _
    , vbYesNo, "NewCopy") = vbNo Then Exit Sub
    
    
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    
    
With Application
               
retry:
    
 'Input box to name new file
NewName = InputBox("Please Specify the name of your new workbook")
            
    
        If StrPtr(NewName) = 0 Then
        
            MsgBox ("User canceled!")
            GoTo reset
                
        Else
        End If
    
        'VBA Check if File Exists
        
        strFile = ThisWorkbook.Path & "\" & NewName & ".xlsx"
    
        If FileExists(strFile) Then
            'File Exists
            MsgBox "The filename you have chosen already exists, please choose a unique filename"
            
        GoTo retry
        
        Else
        End If
End With




Set NewBook = Workbooks.Add


With NewBook


        .title = NewName 'name of new workbook
        .Subject = "Expenses In WorkSheets arranged by Cost Centre or Task Code"
        '       Save it with the NewName and in the same directory as the tool
        .SaveAs ThisWorkbook.Path & "\" & NewName & ".xlsx"


End With
   
Call columntosheets 'filter column and copy to separate sheets


'----------------------------------------------------------------------------------------------------------------------------------------------------------------------
'Start of code section that does not work


'create named tables on each sheet with total rows


For Each ws In ThisWorkbook.Worksheets
        Select Case ws.Name
            Case "Dashboard", "Expenses", "CCRead", "INVRead"  'list the sheets NOT to be worked on
            Case Else
            
                
                With Workbooks("Expenses.xlsm")
                                                                        
                                                                       
                    LastRow = ws.Range("M" & Rows.Count).End(xlUp).Row
                    
                    Range("A1:M20").Select
                    
                    'Range("A" & Lastrow, "M" & Lastrow).Select
                    
                    .ListObjects.Add(1, .Cells(1).CurrentRegion, , 1).Name = "TCCRecords" & ActiveSheet.Name
                    Columns("K").ColumnWidth = 25
                    


Set listob = ws.ListObjects(1)
                    
                    listob.ShowTotals = True
                                    
                                    
                                With ws.ListObjects("TCCRecords" & ActiveSheet.Name)
                                    .ListColumns("Value Excluding VAT £").TotalsCalculation = xlTotalsCalculationSum
                                    .ListColumns("VAT Value £").TotalsCalculation = xlTotalsCalculationSum
                                    .ListColumns("Total  Value £").TotalsCalculation = xlTotalsCalculationSum
                                    .ListColumns("Cost Centre").TotalsCalculation = xlTotalsCalculationNone
                                    
                                    Range("A1").Select
                                
                                
                                End With


                End With
        End Select


    Next
    
'end of code section that does not work
'------------------------------------------------------------------------------------------------------------------------------------------------------------------------




    For Each ws In ThisWorkbook.Worksheets
        Select Case ws.Name
            Case "Dashboard", "Expenses", "CCRead", "INVRead"  'list the sheets NOT to copy
            Case Else
            'copy here
                
                With Workbooks("Expenses.xlsm")
                    'ws.Copy After:=.Sheets(.Sheets.Count) 'copys after last sheet
                
                    ws.Copy Before:=Workbooks(NewName & ".xlsx").Sheets(1)
                
                End With
        End Select


    Next




Workbooks(NewName & ".xlsx").Activate


Application.DisplayAlerts = False
Sheets("Sheet1").Delete
Application.DisplayAlerts = True




'delete the sheets from the main workbook


    For Each ws In ThisWorkbook.Worksheets
            Select Case ws.Name
                Case "Dashboard", "Expenses", "CCRead", "INVRead"  'list the sheets NOT to copy
                Case Else
                'copy here
                    
                    With Workbooks("Expenses.xlsm")
                        'ws.Copy After:=.Sheets(.Sheets.Count) 'copys after last sheet
                        Application.DisplayAlerts = False
                        ws.Delete
                        Application.DisplayAlerts = True


                    End With
            End Select
    
        Next




  
    Exit Sub


reset:
'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True






End Sub
 
Last edited:

Some videos you may like

Excel Facts

Round to nearest half hour?
Use =MROUND(A2,"0:30") to round to nearest half hour. Use =CEILING(A2,"0:30") to round to next half hour.

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
35,618
Office Version
365
Platform
Windows
Try
Code:
   For Each ws In ThisWorkbook.Worksheets
      Select Case ws.Name
         Case "Dashboard", "Expenses", "CCRead", "INVRead"  'list the sheets NOT to be worked on
         Case Else
            ws.ListObjects.Add(1, ws.Cells(1).CurrentRegion, , 1).Name = "TCCRecords" & ActiveSheet.Name
            With ws.ListObjects("TCCRecords" & ActiveSheet.Name)
               ws.Columns("K").ColumnWidth = 25
               .ShowTotals = True
               .ListColumns("Value Excluding VAT £").TotalsCalculation = xlTotalsCalculationSum
               .ListColumns("VAT Value £").TotalsCalculation = xlTotalsCalculationSum
               .ListColumns("Total  Value £").TotalsCalculation = xlTotalsCalculationSum
               .ListColumns("Cost Centre").TotalsCalculation = xlTotalsCalculationNone
            End With
      End Select
   Next
 

Davavo

Board Regular
Joined
Aug 3, 2019
Messages
76
Hello again Fluff,
thanks for your response.

It is doing the same thing. i.e. nothing.

I wonder if the called sub has something to do with it?

here is the code for that...

Code:
Const sname As String = "CCRead" 'change to whatever starting sheetConst s As String = "M" 'change to whatever criterion column


Sub columntosheets()


Dim wb As Workbook


Dim d As Object, a, cc&
Dim p&, i&, rws&, cls&
Set wb = ThisWorkbook


Set d = CreateObject("scripting.dictionary")


With wb.Sheets(sname)
    rws = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
    cls = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    cc = .Columns(s).Column
End With


For Each sh In Worksheets
    d(sh.Name) = 1
Next sh


Application.ScreenUpdating = False
With wb.Sheets.Add(after:=wb.Sheets(sname))
wb.Sheets(sname).Cells(1).Resize(rws, cls).Copy .Cells(1)
.Cells(1).Resize(rws, cls).Sort .Cells(cc), 2, Header:=xlYes
a = .Cells(cc).Resize(rws + 1, 1)
p = 2
For i = 2 To rws + 1
    If a(i, 1) <> a(p, 1) Then
        If d(a(p, 1)) <> 1 Then
            Sheets.Add.Name = a(p, 1)
            .Cells(1).Resize(, cls).Copy Cells(1)
            .Cells(p, 1).Resize(i - p, cls).Copy Cells(2, 1)
        End If
        p = i
    End If
Next i
Application.DisplayAlerts = False
    .Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End With
wb.Sheets(sname).Activate


End Sub
Other symptoms that might provide a clue.

I have a little bit of code in the sheet module that hides the sheet when it is deactivated.
This weirdly stops working after running this code. Until i run one of the other macros that work on the sheet, it stays hidden.
Also, Application.Calculation = xlCalculationAutomatic is at the end of the macro, but it is staying on manual.

:confused:
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
35,618
Office Version
365
Platform
Windows
Is the code in the same workbook as the data you want to turn into tables?
Also does all the data start in A1?
 

Davavo

Board Regular
Joined
Aug 3, 2019
Messages
76
Is the code in the same workbook as the data you want to turn into tables?
Also does all the data start in A1?
Hi, no the code is not in the sheet module. Should it be?

The only code in the sheet module is
Code:
Private Sub Worksheet_Deactivate() Me.Visible = False 'hides the worksheet
End Sub
which isnt really necessary tbh

The table starts at A1:M1 with a header.
A2:M2 is blank.
The data is read in by macro and starts at A3:M3.
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
35,618
Office Version
365
Platform
Windows
Hi, no the code is not in the sheet module. Should it be?
No it doesn't need to be in a sheet module, but is it in the same workbook as the data to be changed?
A2:M2 is blank.
This will be (part of) the problem. Do you have to have a blank row? If you want it converted to a table it's best not to have any blank rows in the data.
 

Davavo

Board Regular
Joined
Aug 3, 2019
Messages
76
ok, sorry, i miss read.

Yes, same workbook at teh poitn when this macro is working. The macro creates new sheets from a filtered column, then copies those new sheets to a new workbook. I am trying to create the table on the sheets before they are copied.

The data source table has spaces. The main sheet has a space at row 2. But the sheets that are created with this macro have no space. Its just the header and data.
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
35,618
Office Version
365
Platform
Windows
In that case try
Code:
   For Each ws In Workbooks(NewName & ".xlsx").Worksheets
      Select Case ws.Name
         Case "Dashboard", "Expenses", "CCRead", "INVRead"  'list the sheets NOT to be worked on
         Case Else
            ws.ListObjects.Add(1, ws.Cells(1).CurrentRegion, , 1).Name = "TCCRecords" & ActiveSheet.Name
            With ws.ListObjects("TCCRecords" & ActiveSheet.Name)
               ws.Columns("K").ColumnWidth = 25
               .ShowTotals = True
               .ListColumns("Value Excluding VAT £").TotalsCalculation = xlTotalsCalculationSum
               .ListColumns("VAT Value £").TotalsCalculation = xlTotalsCalculationSum
               .ListColumns("Total  Value £").TotalsCalculation = xlTotalsCalculationSum
               .ListColumns("Cost Centre").TotalsCalculation = xlTotalsCalculationNone
            End With
      End Select
   Next
This needs to go after the sheets have been added to the new workbook
 

Davavo

Board Regular
Joined
Aug 3, 2019
Messages
76
Yes!
Almost there!

Its creating the tables in the new workbook. The only thing is that the tables are named after the first worksheet only... i.e. sheetname, sheetname_1, sheetname_2

Is this because of the code
Code:
1).Name = "TCCRecords" & ActiveSheet.Name
and the activesheet doesn't change?

I stuck in
Code:
ws.Activate
and it worked!

Code:
For Each ws In Workbooks(NewName & ".xlsx").Worksheets      Select Case ws.Name
         Case "Dashboard", "Expenses", "CCRead", "INVRead"  'list the sheets NOT to be worked on
         Case Else
         ws.Activate
            ws.ListObjects.Add(1, ws.Cells(1).CurrentRegion, , 1).Name = "TCCRecords" & ActiveSheet.Name
            With ws.ListObjects("TCCRecords" & ActiveSheet.Name)
               ws.Columns("K").ColumnWidth = 15
               .ShowTotals = True
               .ListColumns("Value Excluding VAT £").TotalsCalculation = xlTotalsCalculationSum
               .ListColumns("VAT Value £").TotalsCalculation = xlTotalsCalculationSum
               .ListColumns("Total  Value £").TotalsCalculation = xlTotalsCalculationSum
               .ListColumns("Cost Centre").TotalsCalculation = xlTotalsCalculationNone
            End With
      End Select
   Next
Life saver once again Fluff. Thanks a million!
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
35,618
Office Version
365
Platform
Windows
You're welcome & thanks for the feedback

Missed the Activesheet part rather than activateing the sheet you could just replace
Code:
ActiveSheet.Name
with
Code:
ws.Name
in both places.
 

Forum statistics

Threads
1,089,461
Messages
5,408,397
Members
403,201
Latest member
jenmears

This Week's Hot Topics

  • help please
    SORRY NOT ANY GOOD AT EXCEL SO HELP WOULD BE MUCH APPRECIATED this formula is in a sheet called ignore...
  • two formulas needed
    Hello, I'll try my best to explain this: First formula needed in Sheet1 cell A2: If Sheet1 cell B2 = Sheet2 cell B2 then return a 1. If not then...
  • Dynamic Counts
    Good afternoon, we are tidying up some data & the data seems to be growing quicker than we are tidying it up! What we confirm (by reviewing it...
  • Help Excel formula eliminate duplicate values and keep only 2 identical rows.
    as picture below column A has a duplicate value. but the values are not the same as the rule. sometimes 4 rows, sometimes 10 rows or 7 or 9...
  • Macro Compile Error Sub or Function not defined
    Hello, I am trying to run macros from a validation list, all macros have been created and run perfectly on there own but I'm getting a compile...
  • Last row combined with Current Region VBA
    I'm generally happy finding the last row of data through something like Lastrow = Cells(Rows.Count, "D").End(xlUp) but I don't always receive data...
Top