Vba code to restore all tables to just one row

[dsrt16]

I am building a program that other editors can use. I have a workbook where editors track data on the different services they offer. At the end of the year, I want a macro button they can click that first saves their workbook, then restores the spreadsheets to their original state so it is ready to use for the new year, and then prompts them to save it as the new year.

I have coded it to save the workbook, clear out all the data from the unlocked cells, refreshes the pivot table, and then prompts them to save as. The only part I don't know how to do is restore all the tables to just one row.

The spreadsheets contain multiple tables with just one row (and the header row) each. But when they click on new entry, a new row is added to the top of the table. By the end of the year, a table could have grown to 20 or so rows. I want to take it back down to one at the start of the new year. (Since they will want each new entry to be on the top.)

Quarter 1 - Quarter 4 worksheets each contain 5 named tables. On quarter 1: ServiceTable1, ServiceTable2, ServiceTable3, ServiceTable4, ServiceTable5. On quarter 2: ServiceTable2.1, ServiceTable2.2, ServiceTable2.3, ServiceTable2.4, ServiceTable2.5 etc.

On the average hire rate worksheet, there is one table named hirerate.

 Sub NewYear()
Dim cell As Range, Sht As Worksheet

ActiveWorkbook.Save

'right here I want to then have it take every table on every worksheet except the Setup Page and Lists and delete all rows except the first 
' and the header row



'this part of the code then deletes all the data left in the one row so it is cleared and ready for new data

For Each Sht In ThisWorkbook.Worksheets
   If Sht.Name <> "Setup Page" And Sht.Name <> "Lists" Then
    For Each cell In Sht.UsedRange
    If cell.Locked = False Then cell.Value = ""
    Next cell
    End If
 Next Sht
 
 
'then it refreshes the pivot table and prompts a save as

 Call UnprotectRefresh
 Call filesave

End Sub

 

[NoSparks]

Forum member Chris Macro has stuff on his site regarding tables that may be of use, scroll down to Deleting The Entire Table part.

 

[My Aswer Is This]

To delete a entire table you can use this:

Sub Delete_Table()
ActiveSheet.ListObjects("Table1").Range.Delete
End Sub

 

[My Aswer Is This]

To delete all the rows in a Table except for the first two rows try this:

Sub Delete_Table_Rows()
'Modified 3-27-18 8:15 PM EDT
Dim ans As Long
ans = ActiveSheet.ListObjects("Table1").Range.Rows.Count
If ans > 2 Then
ActiveSheet.ListObjects("Table1").Range.Rows("3:" & ans).Delete
End If
End Sub

 

[My Aswer Is This]

To reduce all Tables in all sheets of your workbook to only two rows.
Try this:

Sub Select_All_Tables()
'Modified 3-27-18 9:25 PM EDT
Application.ScreenUpdating = False
Dim TT As ListObject
Dim ans As Long
    For i = 1 To Sheet.Count
    
        With Sheets(i)
            For Each TT In Sheets(i).ListObjects
                ans = TT.Range.Rows.Count
                    If ans > 2 Then
                        TT.Range.Rows("3:" & ans).Delete
                    End If
            Next
        End With
    Next
Application.ScreenUpdating = True
End Sub

 

[dsrt16]

Since the worksheets are protected and I don't need to restore every table in every worksheet (just 5 of the worksheets), I tried this:

Sub RestoreTables()

Application.ScreenUpdating = False

Dim TT As ListObject
Dim ans As Long
Dim sht As Worksheet

   
With Sheet1
         .Unprotect Password:="mypasswordhere"
         .Activate
            
            For Each TT In ActiveSheet.ListObject
                ans = TT.Range.Rows.Count
                    If ans > 2 Then
                        TT.Range.Rows("3:" & ans).Delete
                    End If
            Next TT
        
        .Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
        :=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _
        AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True, Password:="mypasswordhere"
        
   End With
     
  Application.ScreenUpdating = True

End Sub

Then I repeated that with every sheet I needed. It worked great.

Thanks!

 

[My Aswer Is This]

Glad to see you know how to modify scripts to your needs.

Glad I was able to help you.
Come back here to Mr. Excel next time you need additional assistance.

Since the worksheets are protected and I don't need to restore every table in every worksheet (just 5 of the worksheets), I tried this:

Sub RestoreTables()

Application.ScreenUpdating = False

Dim TT As ListObject
Dim ans As Long
Dim sht As Worksheet

   
With Sheet1
         .Unprotect Password:="mypasswordhere"
         .Activate
            
            For Each TT In ActiveSheet.ListObject
                ans = TT.Range.Rows.Count
                    If ans > 2 Then
                        TT.Range.Rows("3:" & ans).Delete
                    End If
            Next TT
        
        .Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowInsertingColumns:=True, AllowInsertingRows _
        :=True, AllowInsertingHyperlinks:=True, AllowDeletingColumns:=True, _
        AllowDeletingRows:=True, AllowSorting:=True, AllowFiltering:=True, _
        AllowUsingPivotTables:=True, Password:="mypasswordhere"
        
   End With
     
  Application.ScreenUpdating = True

End Sub

Then I repeated that with every sheet I needed. It worked great.

Thanks!