Aligning two tables

[acube4gh]

I have two table: BANK STATEMENT and CASH BOOK Firstly, want to compare the amounts, if they are equal then Secondly, check the narration if at least three or four letters match, will pair them. If amount is equal but none of the narration matches, will unmatch them.
I have attached an excel to explain it further.
Thsnks

[mdmackillop]

Welcome to VBAX
This will do the matching. It uses the whole text, reducing to 4 characters so takes a little time. I'll leave you to "reassemble" the data into your desired layout.

Option Explicit


Sub test()
    Dim x, i As Long, f As Range
    Dim r As Range, cel As Range, c As Range, filt As Range
    
    Set r = Range("H:H").SpecialCells(xlCellTypeConstants)
    For Each cel In r
        x = TextArray(cel.Offset(, -1).Formula)
        Range("D:D").AutoFilter 1, "=" & Format(cel, "#,##0.00")
        Set filt = Range("C:C").SpecialCells(xlCellTypeVisible)
        For i = 0 To UBound(x)
            Set f = filt.Find(x(i))
            If Not f Is Nothing Then
                f.Offset(, -2).Resize(, 4).Cut cel.Offset(, 2)
                Exit For
            End If
        Next i
    Next cel
    Range("D:D").AutoFilter
End Sub


Function TextArray(Data As String)
    Dim i As Long, j As Long, m As Long, y As Long, z As Long
    Dim arr()
    Dim Limit
    ReDim arr(10000)
    Limit = 4
    i = Len(Data)
    y = i - 1
    For m = i To Limit Step -1
        For j = 1 To i - y
            arr(z) = Mid(Data, j, m)
            z = z + 1
        Next j
        y = y - 1
    Next m
    ReDim Preserve arr(z - 1)
    TextArray = arr
End Function

[acube4gh]

Thank very much Sir, i tried the macro and only the first and the tenth row matched, the rest didn't. Maybe i am not doing something right. Please advise.

[mdmackillop]

This is my result on your data
tables.jpg

[acube4gh]

Yes Sir, i had the same thing just as in the image you posted and that is not the result i had wanted. i want see the image below;after.JPG

[mdmackillop]

from post #2

I'll leave you to "reassemble" the data into your desired layout.

[acube4gh]

Thanks Sir and i appreciate your efforts very much but i have about 2000 and more rows to match so if after applying the macro and have to reassemble the data, then its just like not using the macro at all and manually match the pair from the scratch.

[mdmackillop]

Option Explicit

Dim LR As Long
 
Sub test()
    Dim x, i As Long, f As Range
    Dim r As Range, cel As Range, c As Range, filt As Range
     
    'For test purpose @@@@@@@@@@@@@@@@@@@@
    Range("data").Copy Cells(1, 1)
    '@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
    Application.ScreenUpdating = False
     
    Set r = Range("H:H").SpecialCells(xlCellTypeConstants)
    For Each cel In r
        x = TextArray(cel.Offset(, -1).Formula)
        Range("D:D").AutoFilter 1, "=" & Format(cel, "#,##0.00")
        Set filt = Range("C:C").SpecialCells(xlCellTypeVisible)
        Range("D:D").AutoFilter
        For i = 0 To UBound(x)
            Set f = filt.Find(x(i))
            If Not f Is Nothing Then
                f.Offset(, -2).Resize(, 4).Cut cel.Offset(, 2)
                Exit For
            End If
        Next i
    Next cel
    Reassemble
    
    'Recheck for duplicate names
    Set r = Range("H:H").SpecialCells(xlCellTypeConstants)
    For Each cel In r
        x = TextArray(cel.Offset(, -1).Formula)
        Range("D" & LR & ":D" & Rows.Count).AutoFilter 1, "=" & Format(cel, "#,##0.00")
        Set filt = Range("C" & LR & ":C" & Rows.Count).SpecialCells(xlCellTypeVisible)
        Range("C" & LR & ":C" & Rows.Count).AutoFilter
        For i = 0 To UBound(x)
            Set f = filt.Find(x(i))
            If Not f Is Nothing Then
                cel.EntireRow.Insert
                f.Offset(, -2).Resize(, 4).Cut Cells(cel.Row - 1, 1)
                LR = Cells(Rows.Count, "G").End(xlUp).Row
                Exit For
            End If
        Next i
    Next cel
    Application.ScreenUpdating = True
End Sub
 
Sub Reassemble()
   
    LR = Cells(Rows.Count, "G").End(xlUp).Row
    Range("A:A").AutoFilter Field:=1, Criteria1:="<>"
    Range("A1:D" & LR).Copy Cells(LR + 2, 1)
    Range("A:A").AutoFilter
    Range("J1:M" & LR).Cut Cells(1, 1)
End Sub
 
Function TextArray(Data As String)
    Dim i As Long, j As Long, m As Long, y As Long, z As Long
    Dim arr()
    Dim Limit
    ReDim arr(10000)
    Limit = 6
    i = Len(Data)
    y = i - 1
    For m = i To Limit Step -1
        For j = 1 To i - y
            arr(z) = Mid(Data, j, m)
            z = z + 1
        Next j
        y = y - 1
    Next m
    ReDim Preserve arr(z - 1)
    TextArray = arr
End Function

[acube4gh]

Thanks Sir, this is what i had after applying the macro.were.JPG
None of transactions matched.

[mdmackillop]

Here's my workbook

[acube4gh]

Wow, Great work done. it worked like magic but please how do i apply this macro for another set of data of the same columns and has about 2000 rows.

[mdmackillop]

Delete the testing line (see revised code above). The code should run on any number of lines in the same layout, but may take time for 2000 rows.

[acube4gh]

Cant find the revised code above. Can you please re-post it. Thanks very much

[acube4gh]

The macro works up to row 996 the it gives the error in the imageerror.JPG below

[mdmackillop]

Post is in #8 above.

I can't test for your error without that amount of data. Delete the first 900 rows and see if it errors at the same location.

[snb]

If you have no knowledge of VBA at all, this forum isn't meant for you. It's purpose is to help people figure out their own VBA projects.

[Aussiebear]

If you have no knowledge of VBA at all, this forum isn't meant for you. It's purpose is to help people figure out their own VBA projects.

Clearly wrong snb. Anybody who visits this forum has the opportunity to learn vba, from the examples the OP's supply and the responses attached to those threads. We should be encouraging others, not putting them down.