Adding New Line to Bottom of Each Sheet Daily

[Wezoin]

Hello everyone,

I have been put in charge of preparing an Excel book for work (despite very limited ability) and have managed to automate a great deal of the process. The book has about 34 sheets, each requiring one row added per day. I have done some perusing on this forum, and found some stuff that has been helpful, but I'm still missing the mark. When I run this code, it starts at 1901 rather than yesterday (which is when the last entries were done).

The code I'm using to add the extra line is:

Private Sub Workbook_Open()

    Dim lastDate As Date
    
'   Go to the first sheet
    Sheets("Aggregate - Europe").Activate
    
'   Check the first value
    lastDate = Range("A" & Rows.Count).End(xlUp)
    If lastDate < Date Then
        Do Until lastDate = Date
            lastDate = Range("A" & Rows.Count).End(xlUp).Select
            ActiveCell.EntireRow.Insert
            lastDate = lastDate + 1
            Range("A" & Rows.Count).End(xlUp) = lastDate
        Loop
    End If
    
End Sub

I adapted it from this thread: How to add new row each day automatically?
Using this video to try to flip it to add rows to the end:

My intent was to get one sheet working before trying to integrate the next sheet code, but I'm not sure how to integrate that into the loop either. The code I found to select next sheet is:

Sub SelectNextSheet()

Dim sht As Worksheet

'Store currently selected sheet
  Set sht = ActiveSheet

'Loop to next sheet until visible one is found
  On Error Resume Next
    
    Do While sht.Next.Visible <> xlSheetVisible
      If Err <> 0 Then Exit Do
        Set sht = sht.Next
    Loop
    
    'Activate/Select next sheet
      sht.Next.Activate
  
  On Error GoTo 0

End Sub

I found this on: VBA Code To Select Next & Previous Spreadsheet Tabs — The Spreadsheet Guru

Could somebody please help me get this working? I'm not sure where I am going wrong.

 

[Wezoin]

Hi Zack,

Thank you very much for your help, it worked great for the first sheet.

Below is a list of the Sheets and Tables (in order):
Aggregate - Europe, Table_3
Aggregate - Operations, Table_243
Aggregate - Baltics, Table_2
Aggregate - Black Sea, Table_1
Albania, Table_5
Austria, Table_4
Bulgaria, Table_10
Belarus, Table_6
Belgium, Table_8
Bosnia, Table_7
Croatia, Table_9
Cyprus, Table_11
Czech Republic, Table_12
Denmark, Table_13
Estonia, Table_15
Finland, Table_14
France, Table_17
Germany, Table_16
Greece, Table_18
Hungary, Table_19
Iceland, Table_20
Ireland, Table_21
Italy, Table_22
Kosovo, Table_23
Latvia, Table_24
Lithuania, Table_25
Moldova, Table_26
Montenegro, Table_27
Norway, Table_29
Netherlands, Table_28
Poland, Table_30
Portugal, Table_31
Romania, Table_32
Russia, Table_33
Serbia, Table_34
Slovakia, Table_35
Slovenia, Table_36
Spain, Table_37
Sweden, Table_38
Switzerland, Table_39
Ukraine, Table_40
United Kingdom, Table_41

Please advise on how to make it do every sheet.

Thanks again for your help, much appreciated.

 

[Zack Barresse]

I'll work on that. In the meantime, are these the only Tables in those worksheets? Do you have any other Tables in the workbooks to exclude? With such a long list, it might be easier to have an exclude list, as opposed to an include list. Or perhaps there's some other way to tell what Tables to perform this on? Perhaps you have this data in a Table somewhere, with a column for Sheet Name and Table Name?

 

[Zack Barresse]

While I would probably put this list on a worksheet somewhere, you can keep it all in VBA if you'd like, as shown in the below code. This should perform the action on every sheet in the key/pair array.

Private Sub Workbook_Open()

    Dim Sheet As Worksheet
    Dim Table As ListObject
    Dim DateColumn As ListColumn
    Dim Index As Long
    Dim LastDate As Date
    Dim LastEmptyDateRow As Long
    Dim AddRowCount As Long
    Dim NewRowCount As Long
    Dim KeyPairs As Variant
    Dim KeyPair As Variant
    Dim Values As Variant

    KeyPairs = Array( _
               Array("Aggregate -Europe", "Table_3"), Array("Aggregate -Operations", "Table_243"), Array("'Aggregate -Baltics", "Table_2"), _
               Array("'Aggregate - Black Sea", "Table_1"), Array("'Albania ", "Table_5"), Array("'Austria ", "Table_4"), _
               Array("'Bulgaria ", "Table_10"), Array("'Belarus ", "Table_6"), Array("'Belgium ", "Table_8"), Array("'Bosnia ", "Table_7"), _
               Array("'Croatia ", "Table_9"), Array("'Cyprus ", "Table_11"), Array("'Czech Republic", "Table_12"), Array("'Denmark ", "Table_13"), _
               Array("'Estonia ", "Table_15"), Array("'Finland ", "Table_14"), Array("'France ", "Table_17"), Array("'Germany ", "Table_16"), _
               Array("'Greece ", "Table_18"), Array("'Hungary ", "Table_19"), Array("'Iceland ", "Table_20"), _
               Array("'Ireland ", "Table_21"), Array("'Italy ", "Table_22"), Array("'Kosovo ", "Table_23"), _
               Array("'Latvia ", "Table_24"), Array("'Lithuania ", "Table_25"), Array("'Moldova ", "Table_26"), _
               Array("'Montenegro ", "Table_27"), Array("'Norway ", "Table_29"), Array("'Netherlands ", "Table_28"), _
               Array("'Poland ", "Table_30"), Array("'Portugal ", "Table_31"), Array("'Romania ", "Table_32"), _
               Array("'Russia ", "Table_33"), Array("'Serbia ", "Table_34"), Array("'Slovakia ", "Table_35"), _
               Array("'Slovenia ", "Table_36"), Array("'Spain ", "Table_37"), Array("'Sweden ", "Table_38"), _
               Array("'Switzerland ", "Table_39"), Array("'Ukraine ", "Table_40"), Array("'United Kingdom", "Table_41") _
                                                                                   )

    Application.ScreenUpdating = False

    For Each KeyPair In KeyPairs

        On Error Resume Next
        Set Sheet = ThisWorkbook.Worksheets(KeyPair(0))
        Set Table = Sheet.ListObjects(KeyPair(1))
        Set DateColumn = Table.ListColumns("Date")
        On Error GoTo 0

        If Not DateColumn Is Nothing Then

            Table.Sort.SortFields.Clear
            Table.Sort.SortFields.Add2 Key:=DateColumn.Range, SortOn:=xlSortOnValues, Order:=xlAscending
            Table.Sort.Header = xlYes
            Table.Sort.Orientation = xlTopToBottom
            Table.Sort.Apply

            LastDate = WorksheetFunction.Max(DateColumn.Range)
            If LastDate = Date Then Exit Sub
            NewRowCount = Date - LastDate
            LastEmptyDateRow = Table.ListRows.Count

            Do Until Len(DateColumn.DataBodyRange(LastEmptyDateRow, DateColumn.Index).Value) <> 0
                LastEmptyDateRow = LastEmptyDateRow - 1
            Loop

            Table.Resize Table.Range.Resize(Table.ListRows.Count + NewRowCount - (Table.ListRows.Count - LastEmptyDateRow) + 1)
            AddRowCount = Table.ListRows.Count - LastEmptyDateRow - NewRowCount
            ReDim Values(0 To NewRowCount - 1)
            For Index = 0 To UBound(Values)
                Values(Index) = LastDate + Index + 1
            Next Index

            DateColumn.DataBodyRange(LastEmptyDateRow + 1).Resize(NewRowCount).Value = Application.Transpose(Values)
            Set DateColumn = Nothing
            
        End If

    Next

    Application.ScreenUpdating = True

End Sub

 

[Wezoin]

Hey Zack,

Thanks again for all your help. We're getting very close, I did a couple adjustments to get it to work (a couple extra apostrophes and spacing issues in the sheet titles), is there a way to make sure it copies columns A-H down? Currently, on some sheets it only copies column A, on others it copies A, B, D, E but not C, F, G, or H. C, F, G, and H are all calculations based off of the B, D, and E (C= B - D - E, F = E / B, etc)

For example, it now goes:

05-Apr-20	361	237	104	20	5.54%	10.75%	33.00%
06-Apr-20	377	240	116	21	5.57%	1.27%	-88.22%
07-Apr-20	383	230	131	22	5.74%	-4.17%	-429.17%
8-Apr-20​	400​		154​	22​
9-Apr-20​	0​		0​	0​

On other sheets simply:

05-Apr-20	19691	13901	3751	1447	7.35%	8.98%	16.54%
06-Apr-20	20814	15196	3986	1632	7.84%	9.32%	3.69%
07-Apr-20	22194	16002	4157	2035	9.17%	5.30%	-43.06%
08-Apr-20
09-Apr-20

(Up to Apr 7 was already entered)

The adjusted code is:

Private Sub Workbook_Open()

    Dim Sheet As Worksheet
    Dim Table As ListObject
    Dim DateColumn As ListColumn
    Dim Index As Long
    Dim LastDate As Date
    Dim LastEmptyDateRow As Long
    Dim AddRowCount As Long
    Dim NewRowCount As Long
    Dim KeyPairs As Variant
    Dim KeyPair As Variant
    Dim Values As Variant

    KeyPairs = Array( _
               Array("Aggregate - Europe", "Table_3"), Array("Aggregate - Operations", "Table_243"), Array("Aggregate - Baltics", "Table_2"), _
               Array("Aggregate - Black Sea", "Table_1"), Array("Albania", "Table_5"), Array("Austria", "Table_4"), _
               Array("Bulgaria", "Table_10"), Array("Belarus", "Table_6"), Array("Belgium", "Table_8"), Array("Bosnia", "Table_7"), _
               Array("Croatia", "Table_9"), Array("Cyprus", "Table_11"), Array("Czech Republic", "Table_12"), Array("Denmark", "Table_13"), _
               Array("Estonia", "Table_15"), Array("Finland", "Table_14"), Array("France", "Table_17"), Array("Germany", "Table_16"), _
               Array("Greece", "Table_18"), Array("Hungary", "Table_19"), Array("Iceland", "Table_20"), _
               Array("Ireland", "Table_21"), Array("Italy", "Table_22"), Array("Kosovo", "Table_23"), _
               Array("Latvia", "Table_24"), Array("Lithuania", "Table_25"), Array("Moldova", "Table_26"), _
               Array("Montenegro", "Table_27"), Array("Norway", "Table_29"), Array("Netherlands", "Table_28"), _
               Array("Poland", "Table_30"), Array("Portugal", "Table_31"), Array("Romania", "Table_32"), _
               Array("Russia", "Table_33"), Array("Serbia", "Table_34"), Array("Slovakia", "Table_35"), _
               Array("Slovenia", "Table_36"), Array("Spain", "Table_37"), Array("Sweden", "Table_38"), _
               Array("Switzerland", "Table_39"), Array("Ukraine", "Table_40"), Array("United Kingdom", "Table_41") _
                                                                                   )

    Application.ScreenUpdating = False

    For Each KeyPair In KeyPairs

        On Error Resume Next
        Set Sheet = ThisWorkbook.Worksheets(KeyPair(0))
        Set Table = Sheet.ListObjects(KeyPair(1))
        Set DateColumn = Table.ListColumns("Date")
        On Error GoTo 0

        If Not DateColumn Is Nothing Then

            Table.Sort.SortFields.Clear
            Table.Sort.SortFields.Add2 Key:=DateColumn.Range, SortOn:=xlSortOnValues, Order:=xlAscending
            Table.Sort.Header = xlYes
            Table.Sort.Orientation = xlTopToBottom
            Table.Sort.Apply

            LastDate = WorksheetFunction.Max(DateColumn.Range)
            If LastDate = Date Then Exit Sub
            NewRowCount = Date - LastDate
            LastEmptyDateRow = Table.ListRows.Count

            Do Until Len(DateColumn.DataBodyRange(LastEmptyDateRow, DateColumn.Index).Value) <> 0
                LastEmptyDateRow = LastEmptyDateRow - 1
            Loop

            Table.Resize Table.Range.Resize(Table.ListRows.Count + NewRowCount - (Table.ListRows.Count - LastEmptyDateRow) + 1)
            AddRowCount = Table.ListRows.Count - LastEmptyDateRow - NewRowCount
            ReDim Values(0 To NewRowCount - 1)
            For Index = 0 To UBound(Values)
                Values(Index) = LastDate + Index + 1
            Next Index

            DateColumn.DataBodyRange(LastEmptyDateRow + 1).Resize(NewRowCount).Value = Application.Transpose(Values)
            Set DateColumn = Nothing
            
        End If

    Next

    Application.ScreenUpdating = True

End Sub

 

[Zack Barresse]

Are you saying that you have calculated columns which aren't getting formulas in the newly inserted blank rows?

 

[Wezoin]

Yes

 

[Zack Barresse]

Then the problem lies in your Tables in the fact that the calculated columns aren't actually calculated columns. You would need to go into each Table, select a cell in the desired column which contains a formula, go into edit mode (press F2 or double-click the cell), press Enter, then click the button which appears and says Overwrite all cells in this column with this formula, as shown in the image below.

 

[Wezoin]

Zack,

Thank you so much - you have saved me several hours of really mind-numbing work over the next few weeks.

 

[Zack Barresse]

Glad I could help. These type of issues can be frustrating if you don't know what you're looking for.