VBA script to copy adjacent cells on same row if duplicate found

Question

I modified the code only at one point because it was what i needed but i need something extra and i can't figure out how to do it.

Here is the original code from this post :

Sub test()

Dim lastRow As Integer, i As Integer Dim cel As Range, rng As Range, sortRng As Range Dim curString As String, nextString As String Dim haveHeaders As Boolean

haveHeaders = False ' Change this to TRUE if you have headers.

lastRow = Cells(1, 1).End(xlDown).Row

If haveHeaders Then 'If you have headers, we'll start the ranges in Row 2 Set rng = Range(Cells(2, 1), Cells(lastRow, 1)) Set sortRng = Range(Cells(2, 1), Cells(lastRow, 2)) Else Set rng = Range(Cells(1, 1), Cells(lastRow, 1)) Set sortRng = Range(Cells(1, 1), Cells(lastRow, 2)) End If ' First, let's resort your data, to get all of the "Column A" values in order, which will group all duplicates together

With ActiveSheet .Sort.SortFields.Clear .Sort.SortFields.Add Key:=rng, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With .Sort .SetRange sortRng .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With

' Now, let's move all "Column B" data for duplicates into Col. C

' We can check to see if the cell's value is a duplicate by simply counting how many times it appears in `rng`
Dim isDuplicate As Integer, firstInstanceRow As Integer, lastInstanceRow As Integer

If haveHeaders Then
    curString = Cells(2, 1).Value
Else
    curString = Cells(1, 1).Value
End If

Dim dupRng As Range      'set the range for the duplicates
Dim k   As Integer

k = 0
For i = 1 To lastRow
    If i > lastRow Then Exit For
    Cells(i, 1).Select
    curString = Cells(i, 1).Value
    nextString = Cells(i + 1, 1).Value
    isDuplicate = WorksheetFunction.CountIf(rng, Cells(i, 1).Value)


    If isDuplicate > 1 Then
        firstInstanceRow = i
        Do While Cells(i, 1).Offset(k, 0).Value = nextString
            'Cells(i, 1).Offset(k, 0).Select
            lastInstanceRow = Cells(i, 1).Offset(k, 0).Row
            k = k + 1
        Loop

        Range(Cells(firstInstanceRow + 1, 2), Cells(lastInstanceRow, 3)).Copy
        Cells(firstInstanceRow, 5).PasteSpecial xlPasteValues
        Application.CutCopyMode = False
        Range(Rows(firstInstanceRow + 1), Rows(lastInstanceRow)).EntireRow.Delete
        k = 0
        lastRow = Cells(1, 1).End(xlDown).Row
    End If

   Next i

End With

End Sub

What i did is:

changed this:

Range(Cells(firstInstanceRow + 1, 2), Cells(lastInstanceRow, 2)).Copy
Cells(firstInstanceRow, 3).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False

to

Range(Cells(firstInstanceRow + 1, 2), Cells(lastInstanceRow, 3)).Copy
Cells(firstInstanceRow, 5).PasteSpecial xlPasteValues
Application.CutCopyMode = False

What i have is:

Column A has duplicates. Column B has unique value. And column C has the qty for the unique values. I it works until the copy and paste part with the exception that it copies either column C under value from column B or the other way is that it copies each value from Column B with the qty from Column C but when it finishes, it deletes all the duplicates.

Example

Column A  Column B  column C
 322       sku322    qty 20
 322       322sku    qty 25

it outputs like

Column D   column E
 sku322     qty 20
 322sku     qty 25

And when it's finished, it delete the second row. This means that i don't have the second unique value.

Or it outputs like:

Column D   Column E
 sku322     322sku
 qty 20     qty 25

And then it delete the last row and i don't have the qty anymore. From my way of thinking if there is no way to paste on the same line, that would mean that after each find it should retake the loop and not copy/paste in bulk. But i tried multiple ways and can't seem to find a way to make it work. Thanks for your help in advance.

Answer 1

Hows this? Screenshot of the results:

Note: If you want the ENTIRE 'unique-sku' column instead of just the country code, change

country = Right(Cells(i, 2), 2)

to

country = Cells(i, 2).Value

Code:

Sub Macro1()
'
' Macro1 Macro
'
    Dim country As String, qty As Integer
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

    ' Headers
    dict("country") = "sum"

    ' Loop through all rows starting on row 2; per Column A
    For i = 2 To Sheets("Sheet1").Cells(1, 1).End(xlDown).Row
        ' Country = last 2 letters of Column B
        country = Right(Cells(i, 2), 2)
        qty = CInt(Cells(i, 3).Value)

        ' If it already exists, add the new amount to the sum.
        If dict.Exists(country) Then
            qty = dict(country) + qty
        End If

        ' This will create it if it doesn't already exist. Otherwise, update.
        dict(country) = qty
    Next

        ' Here are some display options.
        ' Horizontal
        Range("F2").Resize(1, UBound(dict.Keys()) + 1).Value = dict.Keys()
        Range("F3").Resize(1, UBound(dict.Items()) + 1).Value = dict.Items()
        ' Vertical
        Range("F5").Resize(UBound(dict.Keys()) + 1).Value = WorksheetFunction.Transpose(dict.Keys())
        Range("G5").Resize(UBound(dict.Items()) + 1).Value = WorksheetFunction.Transpose(dict.Items())

    Set dict = Nothing
'
End Sub

Answer 2

So i found a workaround, i don't know if it's the most feasable one but it works and for 10.000 rows it does it in 40 seconds to 1 minute max.

You need to create 3 modules and a function (i did not want to put the function in the on the modules.

Module 1

Sub Simplify()

Application.Run "Module9.RemovePart"
Application.Run "Module10.SameRowDuplicates"

End Sub

Module 2

Private Sub RemovePart()
Dim fndList As Variant
Dim fndRplc As Variant

With ActiveSheet
Range("B1").EntireColumn.Insert 'Here i inserted a new column so i can duplicate the first column
Range("A1", Range("A" & Rows.Count).End(xlUp)).Copy ' Copied the first column to the inserted one
Range("B1", Range("B" & Rows.Count).End(xlUp)).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False
        Application.CutCopyMode = False

lastRow = Cells(Rows.Count, "A").End(xlUp).Row ' selected first column to remove the end of the sku
fndList = Array("FR", "DE", "ES") ' here you can just change to whatevery you want to remove
fndRplc = "" ' here is what it replaces it with


  For x = LBound(fndList) To UBound(fndList)


For i = lastRow To 1 Step -1
    Range("A1").EntireColumn.Replace What:=fndList(x), Replacement:=fndRplc, _
        LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False, _
        SearchFormat:=False, ReplaceFormat:=False
 Next i

Next x

End With

End Sub

Module 3

Private Sub SameRowDuplicates()
Dim lastRow As Integer, i As Integer
Dim cel As Range, Rng As Range, sortRng As Range
Dim curString As String, nextString As String
Dim haveHeaders As Boolean

haveHeaders = True          ' Change this to TRUE if you have headers.

lastRow = Cells(1, 1).End(xlDown).Row

If haveHeaders Then          'If you have headers, we'll start the ranges in Row 2
    Set Rng = Range(Cells(2, 1), Cells(lastRow, 1))
    Set sortRng = Range("A2").CurrentRegion
Else
    Set Rng = Range(Cells(1, 1), Cells(lastRow, 1))
    Set sortRng = Range("A1").CurrentRegion
End If
' First, let's resort your data, to get all of the "Column A" values in order, which will group all duplicates together

With ActiveSheet
    .Sort.SortFields.Clear
    .Sort.SortFields.Add Key:=Rng, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With .Sort
        .SetRange sortRng
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

' Now, let's move all "Column B" data for duplicates into Col. C

' We can check to see if the cell's value is a duplicate by simply counting how many times it appears in `rng`
Dim isDuplicate As Integer, firstInstanceRow As Integer, lastInstanceRow As Integer

If haveHeaders Then
    curString = Cells(2, 1).Value
Else
    curString = Cells(1, 1).Value
End If

Dim dupRng As Range      'set the range for the duplicates
Dim k   As Integer

k = 0
For i = 1 To lastRow
    If i > lastRow Then Exit For
    Cells(i, 1).Select
    curString = Cells(i, 1).Value
    nextString = Cells(i + 1, 1).Value
    isDuplicate = WorksheetFunction.CountIf(Rng, Cells(i, 1).Value)


    If isDuplicate > 1 Then
        firstInstanceRow = i
        Do Until Cells(i, 1).Offset(k, 0).Value <> nextString
            'Cells(i, 1).Offset(k, 0).Select
            lastInstanceRow = Cells(i, 1).Offset(k, 0).Row
            k = k + 1
        Loop

        Cells(firstInstanceRow, 5).Formula = "=Combine(" & Range(Cells(firstInstanceRow + 1, 2), Cells(lastInstanceRow, 3)).Address(False, False) & ")" ' combine the results in one row so you have all the duplicates one after another
        Cells(firstInstanceRow, 5).Copy
        Cells(firstInstanceRow, 5).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False
        Application.CutCopyMode = False
        Selection.TextToColumns DataType:=xlDelimited, _ ' this is for converting comma delimited to columns
        ConsecutiveDelimiter:=False, Semicolon:=True ' here you should change your delimiter to what you are using
        Range(Rows(firstInstanceRow + 1), Rows(lastInstanceRow)).EntireRow.Delete
        k = 0
        lastRow = Cells(1, 1).End(xlDown).Row
    End If
Next i

End With

End Sub

Function 1

Function Combine(WorkRng As Range, Optional Sign As String = ";") As String
'Update 20130815
Dim Rng As Range
Dim OutStr As String
For Each Rng In WorkRng
    If Rng.Text <> ";" Then
        OutStr = OutStr & Rng.Text & Sign
    End If
Next
Combine = Left(OutStr, Len(OutStr) - 1)
End Function

So quick story: Module 1 calls for the other modules, i did it this way to make things easier for the end-user so he doesn't see all the modules just needs to click one. Module 2 removes any text from the selected cells Module 3 finds the duplicates and puts them on one line delimited by what you select in the function module. And then deletes the duplicates row. Function 1 takes the output of you selection and puts it on one row delimited.

That is all, thanks for everybody's help and i wish this will help others.