VBA loop code

[Woodsa]

Hello,

I am trying to put some code together, but seem unable to crack it.

I want to check if one cell does not match another cell, then cut the data out and paste to right.

this is what I am trying to achieve:

IF A2 <> D2 'if the value in A2 does not match the value in D2
Cut (D2:E2) 'Cut the data from the rows
Paste G2:H2 'Paste the data below the last set of data
Shift up the now blank row cells 'Cut the data out and paste it in G2 then shift the row up to remove blank cells
Loop 'I want it to stop at this point and then loop through the data starting from the beginning and keep doing this action until all the data matches up

 

[Woodsa]

Book1
	A	B	C	D	E	F	G	H
1
2	102030	102030		102030	102030
3	102030	102030		99999	102030
4	102030	102030		102030	102030
5	102030	102030		102030	102030
6	102030	102030		102030	102030
7	102030	102030		3333	102030
8	102030	102030		102030	102030
9	102030	102030		102030	102030
10
Sheet3

Book1
	A	B	C	D	E	F	G	H
1
2	102030	102030		102030	102030		99999	102030
3	102030	102030		102030	102030		3333	102030
4	102030	102030		102030	102030
5	102030	102030		102030	102030
6	102030	102030		102030	102030
7	102030	102030		102030	102030
8	102030	102030
9	102030	102030
10
11
Sheet3

Hmm perhaps it is my fault, I am using the below data as a test where the 1st and 5th set of numbers do not match. But it is copying all of them off to the right.

231456091	£333.73​		231444881​	£34.14​
231896080	£1,071.44​		231896080	£1,071.44​
234589070	£855.70​		234589070	£855.70​
231222069	£66.16​		231222069	£66.16​
236599058	£240.09​		239692892​	£284.08​
231211547	£609.99​		231211547	£609.99​
232449036	£811.94​		232449036	£811.94​

 

[Woodsa]

Perhaps it is my fault, I am using this data, invoices and the values.

Inv Number	Total		Inv Number	Total
231456091	£333.73		231444881	£34.14
231896080	£1,071.44		231896080	£1,071.44
234589070	£855.70		234589070	£855.70
231222069	£66.16		231222069	£66.16
236599058	£240.09		239692892	£284.08
231211547	£609.99		231211547	£609.99
232449036	£811.94		232449036	£811.94

 

[mohadin]

Try

Sub test()
    Dim i As Long
    Dim drng As Range
    With CreateObject("scripting.dictionary")
        For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
            If Cells(i, 1).Value <> Cells(i, 4).Value Then
                If Not .exists(Cells(i, 1) & Cells(i, 4)) Then
                    .Add Cells(i, 4).Value, Cells(i, 5).Value
                    If drng Is Nothing Then
                        Set drng = Cells(i, 4).Resize(, 2)
                    Else
                        Set drng = Union(drng, Cells(i, 4).Resize(, 2))
                    End If
                End If
            End If
        Next
        drng.Delete Shift:=xlUp
        Cells(2, 7).Resize(.Count, 2) = Application.Transpose(Application.Index(Array(.keys, .items), 0, 0))
    End With
End Sub

 

[Woodsa]

Try

Sub test()
    Dim i As Long
    Dim drng As Range
    With CreateObject("scripting.dictionary")
        For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
            If Cells(i, 1).Value <> Cells(i, 4).Value Then
                If Not .exists(Cells(i, 1) & Cells(i, 4)) Then
                    .Add Cells(i, 4).Value, Cells(i, 5).Value
                    If drng Is Nothing Then
                        Set drng = Cells(i, 4).Resize(, 2)
                    Else
                        Set drng = Union(drng, Cells(i, 4).Resize(, 2))
                    End If
                End If
            End If
        Next
        drng.Delete Shift:=xlUp
        Cells(2, 7).Resize(.Count, 2) = Application.Transpose(Application.Index(Array(.keys, .items), 0, 0))
    End With
End Sub

Hello, I think this is as close as I can get with the logic I was trying and with what I asked for. Now that I have worked through the data more I don't think that this logic will actually work for what I was trying to achieve..

The reason I say that is that I will have data on the left which I need to then match the data on the right to.

The data on the right can have additional lines which would need to be removed, it could have missing data that I would need to add in.

Perhaps there is a way of automating this process, but it will take me a little while longer to figure it out.

 

[Tupe77]

I’m not sure if you’re interested in this anymore, but here would be one possible version.

It moves rows from columns D and (E) that are not found in column A to columns E: F.

If column E "Inv number" matches Column A "Inv number" it moves Column E "Inv number" to the same row as the corresponding column A "Inv number".

The code works on the open sheet of an open workbook.
Columns AX and AY must be empty !!!!!

Sub TS0103()
On Error GoTo ErrHand
Dim ws As Worksheet: Set ws = ThisWorkbook.ActiveSheet
Dim LiUnRNG As Range, TrgRNG As Range, LiUn2RNG As Range, LiUn3RNG As Range, DelRNG As Range, Trg2RNG As Range, x As Long
Set LiUnRNG = ws.Range("A2" & ":" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Address)
Set LiUn2RNG = ws.Range("D2" & ":" & ws.Cells(ws.Rows.Count, "D").End(xlUp).Address)
Set TrgRNG = ActiveSheet.Range("G2")
Application.Calculation = xlManual: Application.ScreenUpdating = False
        Dim i As Integer
        Dim Cell As Range
        Dim dictLiUn As Object
            Set dictLiUn = CreateObject("Scripting.Dictionary")
        
        For Each Cell In LiUnRNG
            If Len(Cell.Value) > 0 Then
                If Not dictLiUn.Exists(Cell.Value) Then
                    dictLiUn.Add Cell.Value, 0
                End If
            Else
            End If
        Next
        
        For Each Cell In LiUn2RNG
            If Len(Cell.Value) > 0 Then
                If Not dictLiUn.Exists(Cell.Value) Then
                    dictLiUn.Add Cell.Value, Cell.Offset(0, 1).Value
                    
                    If DelRNG Is Nothing Then
                        Set DelRNG = Cell.Resize(1, 2)
                    Else
                        Set DelRNG = Union(DelRNG, Cell.Resize(1, 2))
                    End If
                   
                End If
            Else
            End If
        Next
        
        x = 0                             
        For i = 0 To dictLiUn.Count - 1
        If dictLiUn.Items()(i) > 0 Then
            TrgRNG.Offset(x, 0).Value = dictLiUn.Keys()(i)
            TrgRNG.Offset(x, 1).Value = dictLiUn.Items()(i)
            x = x + 1
        End If
        Next i
        
        If Not DelRNG Is Nothing Then DelRNG.Delete Shift:=xlUp        
        
        Set LiUn2RNG = ws.Range("D2" & ":" & ws.Cells(ws.Rows.Count, "D").End(xlUp).Address)
        Set LiUn3RNG = LiUn2RNG.Resize(, 2).Offset(, 46)
        If WorksheetFunction.CountA(LiUn3RNG) > 0 Then MsgBox "range: " & LiUn3RNG.Address & " MUST be EMPTY!": End
        LiUn2RNG.Resize(, 2).Copy LiUn3RNG
        LiUn2RNG.Resize(, 2).ClearContents
        
        For Each Cell In LiUn3RNG.Resize(, 1)
            Set Trg2RNG = LiUnRNG.Find(Cell.Value)
            Cell.Resize(1, 2).Cut Trg2RNG.Offset(0, 3)
        Next
        
        For Each Cell In LiUn2RNG.Offset(0, 1)
            If Len(Cell.Offset(0, -1).Value) > 0 Then
                If Cell.Value <> Cell.Offset(0, -3).Value Then
                Cell.Offset(0, -2).Value = "The amount does not match the reference!"
                End If
            End If
        Next
        
ErrHand:
If Err.Number <> 0 Then MsgBox "ERROR TS0103 FAILED! VBA-code is ended!": Application.Calculation = xlAutomatic: Application.ScreenUpdating = True: End
End Sub