As said, this is take 2 (see linked for Take 1 for my massively beginner code: https://codereview.stackexchange.com/questions/223236/)
As an overview:
I manage the bookkeeping for 40+ companies in an excel workbook. All data is added to a central sheet “Amalgamated Data” and from there data for all transactions for each Company has to be transferred to a sheet for each Company. The single company sheets are then sent to various people at various periods.
All references to the company throught the workbpook are to them as they appear as companyName.
The Code (tested and working – time scale for 40 companies on 400 rows approx 1 min) will be used at least once a day every day. It does the following:
- Checks if there have been any transactions for that Company since the start of the financial year (list of Company’s is held in a separate continuous Column)
If there have been no transactions
If there is an existing tab, clear any transactions from it (clears out any misbookkept entries)
If there are no transactions, check the next company.
- If there have been transactions:
- Check if a sheet exists for the Company
- If no Sheet, set up new tab by copying veryhidden Template preformatted and formula’d
- If a sheet exists (including if set up in previous Step)
Check that a Balance Download Record Exists, if not create one
Check that an Overview Record exists, if not create one
Copy all transactions for that Company to the Company Sheet
I have set this in a loop as the recommendation from Iven Bach of a
Dim companyName as Range For Each companyName created an error13 mismatch in the Worksheet(companyName) type with the Watch window show this as integer instead of Worksheet. I have used loop as this allows me to
Dim companyName as String
Option Explicit SUB UPDATE_BACKUP_SHEETSFIXED() 'This Sub does the following: ' Filter Amalgamated Data by companyName from table list on General Sheet ' Then ' 1. If no data: ' a. Check if a company Tab exists ' i. If not, move on to next company ' ii. If so: ' 1. If there is existing data clear and move to next company ' 2. If no existing data move to next company ' 2. Check if Company tab exists ' a. If tab does not exist, create: ' i. Tab ' ii. Balance Download Record ' iii. Overview Record ' b. If tab does exist (or has just been created above) ' i. If there is data, Clear existing ' ii. Copy transactions from Amalgamated Data Filter Dim amalgamatedDateSheet As Worksheet Set amalgamatedDateSheet = Sheets("Total Data") Dim sourceTable As ListObject Set sourceTable = amalgamatedDateSheet.ListObjects("TableFullData") Dim generalSheet As Worksheet Set generalSheet = Sheets("General") Dim templateSheet As Worksheet Set templateSheet = Sheets("Template") Dim balanceDownloadSheet As Worksheet Set balanceDownloadSheet = Sheets("Balance Download") Dim overviewSheet As Worksheet Set overviewSheet = Sheets("Overview") Dim X As Long X = 4 Application.DisplayAlerts = False Application.ScreenUpdating = False 'Get the Company name from the Company Tab Do Dim companyName As String With generalSheet companyName = .Range("A" & X).Value End With 'Clear all filter from table sourceTable.AutoFilter.ShowAllData 'Filter by Company Name sourceTable.DataBodyRange.AutoFilter Field:=2, Criteria1:="=" & companyName 'Check if transactions exist Dim firstColumnContainsNoVisibleCells As Boolean Dim companySheet As Worksheet On Error Resume Next Set companySheet = Sheets(companyName) On Error Resume Next firstColumnContainsNoVisibleCells = sourceTable.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).count <= 1 On Error GoTo 0 If firstColumnContainsNoVisibleCells Then 'If no transactions If Not companySheet Is Nothing = True Then 'If no transactions but Tab exists for Company Dim targetTable As ListObject Set targetTable = companySheet.ListObjects(1) Dim firstTargetColumnContainsVisibleCells As Boolean On Error Resume Next firstTargetColumnContainsVisibleCells = targetTable.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).count > 1 'If Data present, clear it If firstTargetColumnContainsVisibleCells Then With targetTable .DataBodyRange.Offset(1).Resize(.DataBodyRange.Rows.count - 1, .DataBodyRange.Columns.count).Rows.Delete .DataBodyRange.ClearContents End With End If Call CheckRecordsPresent(balanceDownloadSheet, companyName, overviewSheet) 'If no data present move to next company End If Else 'If transactions exist If Not companySheet Is Nothing = False Then 'If tab for Company does not exist If templateSheet.Visible = xlSheetVeryHidden Then templateSheet.Visible = xlSheetVisible 'Create and rename sheet highlight it yellow templateSheet.Copy After:=Sheets(5) ActiveSheet.Range("A20").ListObject.Name = "Table" & (companyName) ActiveSheet.Name = (companyName) With ActiveSheet.Tab .Color = XlRgbColor.rgbYellow .TintAndShade = 0 End With Set companySheet = Sheets(companyName) 'Hide template templateSheet.Visible = xlSheetVeryHidden 'Confirmation Message MsgBox "Worksheet for " & (companyName) & " created" End If 'If tab and data exist Call CheckRecordsPresent(balanceDownloadSheet, companyName, overviewSheet) 'Clear existing data and resize table Set targetTable = companySheet.ListObjects(1) On Error Resume Next firstTargetColumnContainsVisibleCells = targetTable.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).count > 1 If firstTargetColumnContainsVisibleCells Then With targetTable .DataBodyRange.Offset(1).Resize(.DataBodyRange.Rows.count - 1, .DataBodyRange.Columns.count).Rows.Delete .DataBodyRange.ClearContents End With End If 'Find first row of table (last row of sheet as data previously cleared) Dim lastTargetRow As Long lastTargetRow = companySheet.Range("B" & Rows.count).End(xlUp).Row With sourceTable.DataBodyRange.SpecialCells(xlCellTypeVisible).Copy With companySheet .ListObjects(1).AutoFilter.ShowAllData .Range("A" & lastTargetRow).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone Application.CutCopyMode = False End With End With End If 'Loop back to get a new Company's name in Company Table Set companySheet = Nothing X = X + 1 'Loop back to get a new Company's name in Employee Roster Loop While generalSheet.Range("A" & X).Value <> vbNullString 'At end of loop turn screen refresh etc back on Application.DisplayAlerts = True Application.ScreenUpdating = True amalgamatedDateSheet.Select 'Clear all filter from table sourceTable.AutoFilter.ShowAllData MsgBox "All Sheets Updated" End Sub Private Sub CheckRecordsPresent(ByVal balanceDownloadSheet As Worksheet, ByVal companyName As String, ByVal overviewSheet As Worksheet) 'Check Balance Download Records - create if there isn't one Dim lastBalanceRow As Long lastBalanceRow = balanceDownloadSheet.Range("a" & Rows.count).End(xlUp).Row Dim rangeBalanceDownloadFound As Range Set rangeBalanceDownloadFound = balanceDownloadSheet.Range(balanceDownloadSheet.Range("A4"), balanceDownloadSheet.Range("A" & lastBalanceRow)).Find(companyName) If rangeBalanceDownloadFound Is Nothing Then With balanceDownloadSheet .ListObjects(1).ListRows.Add .Rows(lRow).Copy .Range("A" & lastBalanceRow + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone Application.CutCopyMode = False .Range("a" & lRow + 1).Value = companyName End With End If 'Check if front page record exists Dim lastOverviewRow As Long lastOverviewRow = overviewSheet.Range("a" & Rows.count).End(xlUp).Row Dim rangeOverviewFound As Range Set rangeOverviewFound = overviewSheet.Range(overviewSheet.Range("A6"), overviewSheet.Range("A" & lastOverviewRow)).Find(companyName) If rangeOverviewFound Is Nothing Then With overviewSheet .Range("A53:E53").Copy .Range("A53:E53").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove .Range("A53").Value = companyName End With End If End Sub
Massive thanks to IvenBack, AJD and Mathieu Guindon for unravelling my (miraculously working) ridiculously messy previous code attempt, below is take 2 that I hope is much more streamlined and removes all (?!) of the redundant lines. Hopefully this is much improved and not too much of a bastardisation of the brilliant recommendations and codes you wrote.
All help gratefully received as I still have a long way to go.