copy, offset, paste, then delete loop

**Spyderwoman** · 05-22-2018, 03:58 PM

I need serious help, not sure what to do first and I'm not sure what would be the most efficient, but the end result is: delete the duplicate ID number in column A, entire row delete, copy the number below the original ID number and move that number next to the original number in column B. (There's other data in the other columns but are of no consequence). The pattern is ID, amount, Duplicate ID. I need to keep ID and amount. Not sure if I should delete every 3 row first. Any help will be greatly appreciated. I've attached a worksheet and hope this makes sense.
thank you in advance for your assistance.

**PCI** · 05-22-2018, 04:20 PM

The duplicates have to be seen from the beginning , is it?
It means the first occurance is data to keep

**PCI** · 05-22-2018, 04:27 PM

Can we say that that "key" have "-" inside ?

**PCI** · 05-22-2018, 04:44 PM

Is it what you want ...?
See next code, much be launch from sheet with data
Take care that original data is deleted


Option Explicit
Sub Treat()
Dim KeyDic   As Object
Set KeyDic = CreateObject("Scripting.Dictionary")
Dim LR  As Integer, I  As Integer
Const FR  As Integer = 2
Dim AAA, BBB
Dim WkKey  As String
    LR = Cells(Rows.Count, "A").End(3).Row
    For I = FR To LR
        WkKey = Cells(I, "A")
        If (WkKey Like "*-*") Then
            If Not (KeyDic.exists(WkKey)) Then
                KeyDic.Item(WkKey) = Cells(I, "A").Offset(1, 0).Value
            End If
        End If
    Next I
    Cells.ClearContents
    With KeyDic
        Cells(2, 1).Resize(.Count, 1) = Application.Transpose(.keys)
        Cells(2, 2).Resize(.Count, 1) = Application.Transpose(.items)
    End With
End Sub