Help with Excel Macro

[Capamaru]

Hello all.

This is my first post here and I am happy to be a new member on this forum.

I need your help to do the following. As you can see in the picture the macro must check for multiple appearances of code in column A and then move the marked data as shown. The process must loop for all the appearances of the same code, so if the code 0304-10-1310 appeared for a third and fourth time then the corresponding marked data should be moved to cells N, O, P and Q, R, S respectively. After the copy the multiple rows must be deleted.

Thank you all in advance for your time

 

[MrKowz]

Welcome to the forums!

Will the duplicated lines in Column A always appear next to each other, or will they appear in random locations?

 

[MrKowz]

Try out this (untested) macro - it isn't dependant on the cells being contiguously next to each other:

Public Sub Capamaru()
Dim i       As Long, _
    LR      As Long, _
    rng     As Range, _
    rngFind As Range, _
    dupCnt  As Long
    
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
    
LR = Range("A" & rows.Count).End(xlUp).Row
For Each rng In Range("A2:A" & LR)
    Application.StatusBar = "Currently checking row: " & rng.Row
    dupCnt = 0
    If rng.Value = vbNullString Then Exit For
        With Range(rng.Offset(1, 0), Cells(LR, 1))
            Set rngFind = .Find(rng.Value, after:=rng, LookIn:=Values, lookat:=whole)
            If Not rngFind Is Nothing Then
                Do
                    Cells(rng.Row, 10 + (dupCnt * 4)).Value = rng1.Offset(0, 1).Value
                    Cells(rng.Row, 11 + (dupCnt * 4)).Value = rng1.Offset(0, 6).Value
                    Cells(rng.Row, 12 + (dupCnt * 4)).Value = rng1.Offset(0, 7).Value
                    Cells(rng.Row, 13 + (dupCnt * 4)).Value = rng1.Offset(0, 8).Value
                    rngFind.EntireRow.Delete
                    dupCnt = dupCnt + 1
                    Set rngFind = .FindNext(rngFind)
                Loop While Not rngFind Is Nothing
            End If
        End With
    End If
Next rng
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationAutomatic
    .StatusBar = False
End With
End Sub

 

[Capamaru]

Column A will be sorted by code or the macro can do it.

 

[Capamaru]

It doesn't work. I fixed the end if error and then I get a runtime error 13 type mismatch

 

[MrKowz]

Can you please tell me where it is erroring?

 

[Capamaru]

Try out this (untested) macro - it isn't dependant on the cells being contiguously next to each other:

Public Sub Capamaru()
Dim i       As Long, _
    LR      As Long, _
    rng     As Range, _
    rngFind As Range, _
    dupCnt  As Long
    
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
    
LR = Range("A" & rows.Count).End(xlUp).Row
For Each rng In Range("A2:A" & LR)
    Application.StatusBar = "Currently checking row: " & rng.Row
    dupCnt = 0
    If rng.Value = vbNullString Then Exit For
        With Range(rng.Offset(1, 0), Cells(LR, 1))
            [B]Set rngFind = .Find(rng.Value, after:=rng, LookIn:=Values, lookat:=whole)[/B]
            If Not rngFind Is Nothing Then
                Do
                    Cells(rng.Row, 10 + (dupCnt * 4)).Value = rng1.Offset(0, 1).Value
                    Cells(rng.Row, 11 + (dupCnt * 4)).Value = rng1.Offset(0, 6).Value
                    Cells(rng.Row, 12 + (dupCnt * 4)).Value = rng1.Offset(0, 7).Value
                    Cells(rng.Row, 13 + (dupCnt * 4)).Value = rng1.Offset(0, 8).Value
                    rngFind.EntireRow.Delete
                    dupCnt = dupCnt + 1
                    Set rngFind = .FindNext(rngFind)
                Loop While Not rngFind Is Nothing
            End If
        End With
   [B] End If[/B]
Next rng
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationAutomatic
    .StatusBar = False
End With
End Sub

The bold parts are marked as errors in debugger

 

[MrKowz]

Try this out - i think the rngFind line was erroring because rng wasn't a part of the array the .Find method was looking at.

As for the End If line, that was a force of habit error:

Public Sub Capamaru()
Dim i       As Long, _
    LR      As Long, _
    rng     As Range, _
    rngFind As Range, _
    dupCnt  As Long
    
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
    
LR = Range("A" & rows.Count).End(xlUp).Row
For Each rng In Range("A2:A" & LR)
    Application.StatusBar = "Currently checking row: " & rng.Row
    dupCnt = 0
    If rng.Value = vbNullString Then Exit For
    With Range(rng.Offset(1, 0), Cells(LR, 1))
        Set rngFind = .Find(rng.Value, LookIn:=Values, lookat:=whole)
        If Not rngFind Is Nothing Then
            Do
                Cells(rng.Row, 10 + (dupCnt * 4)).Value = rng1.Offset(0, 1).Value
                Cells(rng.Row, 11 + (dupCnt * 4)).Value = rng1.Offset(0, 6).Value
                Cells(rng.Row, 12 + (dupCnt * 4)).Value = rng1.Offset(0, 7).Value
                Cells(rng.Row, 13 + (dupCnt * 4)).Value = rng1.Offset(0, 8).Value
                rngFind.EntireRow.Delete
                dupCnt = dupCnt + 1
                Set rngFind = .FindNext(rngFind)
            Loop While Not rngFind Is Nothing
        End If
    End With
Next rng
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationAutomatic
    .StatusBar = False
End With
End Sub

 

[Capamaru]

Still get the error on

Set rngFind = .Find(rng.Value, LookIn:=Values, lookat:=whole)

 

[MrKowz]

Change that line to:

        Set rngFind = .Find(rng.Value, LookIn:=xlValues, lookat:=xlWhole)