Debits and Credits to offset in a column

[kjaan]

Hi,
I have a large data that I exported in excel that include debit and credit in a column. I would like to find an easier way to pair the debit and credit to offset each other by a formula and easily find the variance. So the column would look something like this.

Column A
250
400
350
-250
410
-400
-350
600
-410

 

[DachoR]

If you put only these values, like below, and run the macro you will be able to see what the problem is.
In column A put values by this order 240, -240, 240, -240.
In column B put references by this order 10107231971906, 10107932392111, 10107932392111, 10107932392111.
As you can see we have 3 identical references, and if you run the macro you will see the mistake

 

[Trebor76]

Try this:

Option Explicit
Sub Macro6()

    'Matches reference numbers in column B where the amount for that reference number is initially positive

    Dim lngEndRow    As Long
    Dim rngMyCell    As Range
    Dim rngMatchCell As Range
    
    Application.ScreenUpdating = False
    
    'Find the last row across columns A and B
    lngEndRow = Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    'Sort the range by reference number (lowest to highest) and amount (highest to lowest)
    'Range("A1:B" & lngEndRow).Sort key1:=Range("B1:B" & lngEndRow), order1:=xlAscending, Header:=xlNo, key2:=Range("A1:A" & lngEndRow), order2:=xlDescending, Header:=xlNo
    
    For Each rngMyCell In Range("A1:A" & lngEndRow) 'Amount column
        If Val(rngMyCell) > 0 And rngMyCell.Font.Bold = False And Len(rngMyCell) > 0 Then 'Only try and match the first reference if its amount is positive
            For Each rngMatchCell In Range("A1:A" & lngEndRow)
                If Val(Range("A" & rngMatchCell.Row)) * -1 = Val(Range("A" & rngMyCell.Row)) And Range("B" & rngMatchCell.Row) = Range("B" & rngMyCell.Row) Then
                    With Range("A" & rngMyCell.Row & ":B" & rngMyCell.Row)
                        .Copy Destination:=Range("C" & rngMyCell.Row)
                        .ClearContents
                    End With
                    With Range("A" & rngMatchCell.Row & ":B" & rngMatchCell.Row)
                        .Copy Destination:=Range("C" & rngMatchCell.Row)
                        .ClearContents
                    End With
                    Exit For
                End If
            Next rngMatchCell
        ElseIf Val(rngMyCell) < 0 And Len(rngMyCell) > 0 Then
            rngMyCell.Font.Bold = True
            For Each rngMatchCell In Range("A1:A" & lngEndRow)
                If Val(rngMatchCell) * -1 = Val(rngMyCell) And Range("B" & rngMatchCell.Row) = Range("B" & rngMyCell.Row) Then
                    rngMatchCell.Font.Bold = True
                    Exit For
                End If
            Next rngMatchCell
        End If
    Next rngMyCell
    
    Application.ScreenUpdating = True
    
    MsgBox "Done", vbInformation
    
End Sub

 

[DachoR]

I think this is the closest one!
It has matched all the necessary values except these 240 and -240.
It bolded all three values -240, 240 and -240 with same reference but it has not matched any of them.
But it's much better not to match any of them than to match them wrongly.
It's significant progress, I am satisfied with this one.
But if you get any idea how to solve this tricky part with above values please let me know.