0
\$\begingroup\$

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 
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Browse other questions tagged or ask your own question.