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

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.
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.

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.