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]

I was experimenting with this, but quickly realised that I needed some kind of dynamic Loop function to be able to look through all of the data

Sub Tests()
Dim lrow As Long
lrow = Cells(Rows.Count, "G").End(xlUp).Row

If Range("A3") <> Range("D3") Then
Range("D3:E3").Copy Range("G" & lrow).Offset(1, 0)
Else:
End If
End Sub

 

[Tupe77]

You can try:

Sub transit()
Dim RangeA As Range, Cell As Range
Set RangeA = Selection

For Each Cell In RangeA
If Cell.Value <> Cell.Offset(, 3).Value Then
Cell.Offset(, 3).Resize(1, 2).Cut Cell.Offset(, 6).Resize(1, 2)
End If
Next

End Sub

 

[Woodsa]

You can try:

Sub transit()
Dim RangeA As Range, Cell As Range
Set RangeA = Selection

For Each Cell In RangeA
If Cell.Value <> Cell.Offset(, 3).Value Then
Cell.Offset(, 3).Resize(1, 2).Cut Cell.Offset(, 6).Resize(1, 2)
End If
Next

End Sub

Hey,

Thank you for taking the time to look at this, can you explain how it works?

I am trying to get it to loop through each line, if it doesn't match then I want to to cut it out, close the gap and check again to see if it matches.

 

[mohadin]

Try

Sub test()
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    With CreateObject("scripting.dictionary")
        For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
            If Cells(i, 4) <> Cells(i, 5) Then
                If Not .exists(Cells(i, 1) & Cells(i, 4)) Then
                    .Add Cells(i, 4).Value, Cells(i, 5).Value
                    Cells(i, 4).Resize(, 2).Delete Shift:=xlUp
                End If
            End If
        Next
        Cells(2, 7).Resize(.Count, 2) = Application.Transpose(Application.Index(Array(.keys, .items), 0, 0))
    End With
End Sub

 

[Woodsa]

Try

Sub test()
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    With CreateObject("scripting.dictionary")
        For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
            If Cells(i, 4) <> Cells(i, 5) Then
                If Not .exists(Cells(i, 1) & Cells(i, 4)) Then
                    .Add Cells(i, 4).Value, Cells(i, 5).Value
                    Cells(i, 4).Resize(, 2).Delete Shift:=xlUp
                End If
            End If
        Next
        Cells(2, 7).Resize(.Count, 2) = Application.Transpose(Application.Index(Array(.keys, .items), 0, 0))
    End With
End Sub

Wow, this is very complex haha, I have tried it and didn't get any errors, but I am not sure what has happened, it has copied a few rows of data to different columns, but the logic isn't right.

 

[mohadin]

Well,
May be the result is upside down
Cause started from the bottom up
!!!

 

[mohadin]

Try this version

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, 4) <> Cells(i, 5) 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 this version

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, 4) <> Cells(i, 5) 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

Thank you very much for looking into this, it seems to just be copying all the data to rows D:E and not matching at all

 

[mohadin]

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