I have written the below working Code to speed up the summarisation of transaction data into a reduced format whilst also checking and providing feedback where there is no data to transfer.
Overview: I manage the bookkeeping for 40+ companies in an excel workbook. All transactions are added to a central sheet "Amalgamated Data" and from there I need to provide a summary of all outgoing payments only between 2 dates set by the User in an easier to digest format than that provided in the Amalgamated Sheet.
It's currently taking approx 2 mins to execute on a filtered set of generally about 30 rows. Is there any optimisation that can be made to try to speed this up? All help, thoughts and recommendation gratefully received.
Thanks
R
Option Explicit
Sub UpdatePayments()
'This Sub does the following
' Filter Amalgamated Table by dates defined on Overview Sheet
' 1. If no transactions within data range tell me
' a. Tell me and Exit Sub – no changes made
' 2. If transactions do exist
' a. Copy Payment info only
' b. Rearrange Data and reformat
' c. Filter to remove incoming payments
' i. If no outgoing transactions (ie any remaining rows) tell me and Exit Sub
' d. Copy payments to front sheet
'
Dim overviewSheet As Worksheet
Set overviewSheet = Sheets("Overview")
Dim paymentFinalTable As ListObject
Set paymentFinalTable = overviewSheet.ListObjects("TablePayments")
Dim amalgamatedDateSheet As Worksheet
Set amalgamatedDateSheet = Sheets("Amalgamated Data")
Dim sourceTable As ListObject
Set sourceTable = amalgamatedDateSheet.ListObjects("TableFullData")
Dim paymentHelperSheet As Worksheet
Set paymentHelperSheet = Sheets("Payments")
On Error Resume Next
'Unhide Helper Sheet
If paymentHelperSheet.Visible = xlSheetVeryHidden Then paymentHelperSheet.Visible = xlSheetVisible
On Error GoTo 0
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim paymentHelperTable As ListObject
Set paymentHelperTable = paymentHelperSheet.ListObjects("TablePaymentsInt")
' Clear all filter from table
sourceTable.AutoFilter.ShowAllData
'Filter by Date
Dim startDate As Long, endDate As Long
startDate = overviewSheet.Range("J8").Value
endDate = overviewSheet.Range("L8").Value
sourceTable.Range.AutoFilter Field:=4, _
Criteria1:=">=" & startDate, _
Operator:=xlAnd, _
Criteria2:="<=" & endDate
' Filter by Payment Type
sourceTable.Range.AutoFilter Field:=8, _
Criteria1:="Payment"
'If no payments at all ask for next steps
On Error Resume Next
Dim noTransactionsInPeriod As Boolean
noTransactionsInPeriod = sourceTable.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count <= 1
On Error GoTo 0
If noTransactionsInPeriod Then
Dim Result As Integer
MsgBox "No Transactions within period" & vbCrLf & "from: " & overviewSheet.Range("J8") & vbCrLf & "to: " & overviewSheet.Range("L8"), vbOKOnly
sourceTable.AutoFilter.ShowAllData
paymentHelperSheet.Visible = xlSheetVeryHidden
'Update Screen updating
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Payment information not transferred"
Exit Sub
'If there are outward payments
Else
'Copy Data to intermediate sheet
sourceTable.Range.SpecialCells(xlCellTypeVisible).Copy _
Destination:=paymentHelperSheet.Range("A4")
'Move Columns around
On Error Resume Next
Dim lastTargetRow As Long
lastTargetRow = paymentHelperSheet.Range("B" & Rows.Count).End(xlUp).Row
On Error GoTo 0
paymentHelperTable.AutoFilter.ShowAllData
With paymentHelperSheet
.Columns("D:D").Cut
.Columns("B:B").Insert Shift:=xlToRight
.Columns("G:G").Cut
.Columns("C:C").Insert Shift:=xlToRight
.Columns("R:R").Cut
.Columns("E:E").Insert Shift:=xlToRight
.Columns("D:E").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
.Columns("G:G").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
.Range("G5").Formula = _
"=IF(RIGHT(L5,3)=""O/D"",L5,CONCATENATE(L5,"" - "",K5))"
.Range("G:G").Copy
.Range("G:G").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("D5").Formula = _
"=IF(M5<0,""EUR"",IF(N5<0,""GBP"",IF(O5<0,""USD"","""")))"
.Range("E5").Formula = _
"=IF(M5<0,-M5,IF(N5<0,-N5,IF(O5<0,-O5,"""")))"
.Columns("D:E").Copy
.Columns("D:E").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Columns("H:X").Delete
'Correct formatting of columns
.Columns("B:B").NumberFormat = "dd/mm/yyyy"
.Columns("C:D").NumberFormat = "General"
.Columns("E:E").Style = "Comma"
.Columns("F:H").NumberFormat = "General"
End With
'Filter all inward payments for deletion
paymentHelperTable.Range.AutoFilter Field:=4, Criteria1:="="
'Check if inward payments
Dim inwardPaymentsPresent As Boolean
On Error Resume Next
inwardPaymentsPresent = paymentHelperTable.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count >= 1
On Error GoTo 0
If inwardPaymentsPresent Then
'If inward payments, delete rows
paymentHelperTable.DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
End If
paymentHelperTable.AutoFilter.ShowAllData
If paymentHelperSheet.Range("A5") = vbNullString Then
MsgBox "No outgoing payments within period" & vbCrLf & "from: " & overviewSheet.Range("J8") & vbCrLf & "to: " & overviewSheet.Range("L8"), vbOKOnly
'Hide Payment intermediate sheet
sourceTable.AutoFilter.ShowAllData
paymentHelperSheet.Visible = xlSheetVeryHidden
'Update Screen updating
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Payment information not transferred"
Exit Sub
Else
'Clear existing data
If overviewSheet.Range("I11") <> vbNullString Then
With paymentFinalTable
.AutoFilter.ShowAllData
.DataBodyRange.Offset(1, 0).Resize(.DataBodyRange.Rows.Count - 1, .DataBodyRange.Columns.Count).Rows.Delete
.DataBodyRange.ClearContents
End With
'Copy Data
End If
Dim lRow As Long
lRow = overviewSheet.Range("I" & Rows.Count).End(xlUp).Row
paymentHelperTable.DataBodyRange.Copy
With overviewSheet
.Range("I" & lRow).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone
Application.CutCopyMode = False
End With
End If
End If
' Clear all filter from table
sourceTable.AutoFilter.ShowAllData
paymentHelperTable..DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
'Hide Payment intermediate sheet
paymentHelperSheet.Visible = xlSheetVeryHidden
'Update Screen updating
Application.ScreenUpdating = True
Application.DisplayAlerts = True
'Message successful
MsgBox "Payments Transferred"
End Sub
