If dupplicate values found in column A - copy/paste range B:D of the dupplicates on the same row of the original value

clairexcel · Jul 2nd 2022

Hi there,

I have a bit of a conundrum: multiple files (price lists) with an average of 15000 rows.

These price lists have in column A the item's ID, in column B the price and in column C the quantity for that particular price. Now, some items are duplicated from 2 to even 5 times, as prices for these items are qty based/scaled.

Problem is I have to have these files with scaled prices per column and not per rows.

WHat I have been trying to do (mostly with formulas, whithout success) is: Find the duplicates in column A, and If dupplicate found paste the range B:D on the same row of the first ID matching, as many times as matches found. I'll show you in the example below. This is the starting file

What I need to do (preferably VBA as there are files that have up to 25000 rows), is obtain this, please see what I did with items X8 and X 17:

code	price-1	from qty	to qty
X1	3,00 €	1
X2	2,00 €	1
X3	5,00 €	1
X4	3,00 €	1
X5	11,00 €	1
X6	6,00 €	1
X7	8,00 €	1
X8	4,00 €	1
X8	8,00 €	10
X8	6,00 €	20
X9	3,00 €	1
X10	2,00 €	1
X11	5,00 €	1
X12	3,00 €	1
X13	11,00 €	1
X14	6,00 €	1
X15	8,00 €	1
X16	4,00 €	1
X17	7,00 €	10
X17	6,00 €	20
X17	5,00 €	30

code	price-1	from qty	to qty	price-2	from qty2	to qty2	price-3	from qty3
X1	3,00 €	1
X2	2,00 €	1
X3	5,00 €	1
X4	3,00 €	1
X5	11,00 €	1
X6	6,00 €	1
X7	8,00 €	1
X8	4,00 €	1		8,00 €	10		6,00 €	20
X9	3,00 €	1
X10	2,00 €	1
X11	5,00 €	1
X12	3,00 €	1
X13	11,00 €	1
X14	6,00 €	1
X15	8,00 €	1
X16	4,00 €	1
X17	7,00 €	10		6,00 €	20		5,00 €	30

I attach the file I have been working with. PLease ignore the modules I have in it, they are codes I found online and have been trying to workarround work arround those, as well as some formulas but I haven't been able to obtain what I needed.

Anyhow, thank you in advance for any suggestion or help.

**KjBox** · Jul 2nd 2022

No file attached

clairexcel · Jul 2nd 2022

Quote from KjBox

No file attached

Oh sorry for the mishap, here it is.

**KjBox** · Jul 3rd 2022

Try this

Code

Sub DupsToCols()
    Dim x, y, i&, ii&, iii&, iv&, v&, vi&
    
    With Foglio1.ListObjects(1).DataBodyRange
        x = .Value
        ReDim y(1 To UBound(x, 1), 1 To UBound(x, 2))
        For i = 1 To UBound(x, 1)
            vi = i
            For ii = 1 To 4
                y(vi, ii) = x(i, ii)
            Next
            If x(i, 1) = x(i + 1, 1) Then
                i = i + 1: iii = 3: iv = 1
                Do Until x(i, 1) <> x(i - 1, 1)
                    v = iii * iv
                    For ii = 2 To 4
                        y(vi, ii + v) = x(i, ii)
                    Next
                    i = i + 1: iv = iv + 1
                    If i > UBound(x, 1) Then Exit Do
                Loop
                i = i - 1
            End If
        Next
        .Value = y
    End With
    With Foglio1.ListObjects(1)
        For i = UBound(x, 1) To 1 Step -1
            If IsEmpty(y(i, 1)) Then .ListRows(i).Delete
        Next
        With .DataBodyRange
            .Columns(2).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;_-@_-"
            .Columns(5).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;_-@_-"
            .Columns(8).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;_-@_-"
            .Columns(11).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;_-@_-"
        End With
    End With
    
End Sub

Display More

**KjBox** · Jul 3rd 2022

If all you "Price List" files are in a single folder, and no other files in that folder, then it would be possible write code to loop through all the files and reformat the Table as required.

clairexcel · Jul 3rd 2022

Quote from KjBox

If all you "Price List" files are in a single folder, and no other files in that folder, then it would be possible write code to loop through all the files and reformat the Table as required.

No , unfortunately are not in the same folder, every customer/supplier has its own folder, it is a company requirement.

But the idea is of couse brilliant..

clairexcel · Jul 3rd 2022

Kjbox, what can I say besides THANK YOU? You have saved my work once again.... SO very much aprecciated.

The code works wonderfully and very fast.

The only problem is I made a trial with the table adding 4 rows of dupplicates for X17, but it gives me an error, this is the line that Debug highlights:

y(vi, ii + v) = x(i, ii)

I tried to increase the number for : For ii = 2 To 5

But it still gives the error.

Why is that? I may have up to five dupplicates for a price.

Thank you really Kjbox, this is fine quality code and for the n-th time you have saved my hours at work!

**KjBox** · Jul 3rd 2022

You're welcome.

The reason for the error is that your Table allows for only up to 4 duplicates, add 3 columns to you table, "price-5", "from qty5" & "to qty5".

Also the formatting for "price-5" needs to be added to the code

Amended code

Code

Sub DupsToCols()
    Dim x, y, i&, ii&, iii&, iv&, v&, vi&
    
    Application.ScreenUpdating = 0
    With Foglio1.ListObjects(1).DataBodyRange
        x = .Value
        ReDim y(1 To UBound(x, 1), 1 To UBound(x, 2))
        For i = 1 To UBound(x, 1)
            vi = i
            For ii = 1 To 4
                y(vi, ii) = x(i, ii)
            Next
            If x(i, 1) = x(i + 1, 1) Then
                i = i + 1: iii = 3: iv = 1
                Do Until x(i, 1) <> x(i - 1, 1)
                    v = iii * iv
                    For ii = 2 To 4
                        y(vi, ii + v) = x(i, ii)
                    Next
                    i = i + 1: iv = iv + 1
                    If i > UBound(x, 1) Then Exit Do
                Loop
                i = i - 1
            End If
        Next
        .Clear
        .Value = y
    End With
    With Foglio1.ListObjects(1)
        For i = UBound(x, 1) To 1 Step -1
            If IsEmpty(y(i, 1)) Then .ListRows(i).Delete
        Next
        With .DataBodyRange
            .Columns(2).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;_-@_-"
            .Columns(5).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;_-@_-"
            .Columns(8).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;_-@_-"
            .Columns(11).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;_-@_-"
            .Columns(14).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;_-@_-"
        End With
    End With
    
End Sub

Display More

clairexcel · Jul 3rd 2022

Quote from KjBox

You're welcome.

The reason for the error is that your Table allows for only up to 4 duplicates, add 3 columns to you table, "price-5", "from qty5" & "to qty5".

Also the formatting for "price-5" needs to be added to the code

Amended code

Display More

KjBox thank you!! I added the formatting in the code for price -5, but I mess up the For ii = 1 To 4 part.

It is working, and I cannot express enough appreciation for your time and help.

Thank you!

**KjBox** · Jul 3rd 2022

You're welcome

clairexcel · Jul 4th 2022

KjBox hi, I am so sorry to trouble you again, but at work with real code items this code gives me this error:

Next

If x(i, 1) = x(i + 1, 1) Then

The error I get in the message of Debug is this one:

While on the table with fictional data works wonderfully and fast, on the table I have at work, it doesn't.

I thought the real format of the item's id (in col. A ) was to blame, because otherwise I ca't explain to myself why the code works perfectly in the sample table of yesterday, and in this one it doesn't.

I attach a sample of the table I have at work, with the item's code in the format as it is (I of course changed didgits and letters)

Can you please see why it keeps giving me this error? Thank you in advance...

**KjBox** · Jul 4th 2022

The error is because the sheet code name was different ("Foglio2" instead of "Foglio1"). The code below will work with any sheet code name, but the sheet that needs to have duplicates put into columns must be the active sheet.

Note that the Table on the actual data example only allows for up to 4 duplicates so the previous error will occur if there are 5 duplicates.

Code

Sub DupsToCols()
    Dim x, y, i&, ii&, iii&, iv&, v&, vi&
    
    Application.ScreenUpdating = 0
    With ActiveSheet.ListObjects(1).DataBodyRange
        x = .Value
        ReDim y(1 To UBound(x, 1), 1 To UBound(x, 2))
        For i = 1 To UBound(x, 1)
            vi = i
            For ii = 1 To 4
                y(vi, ii) = x(i, ii)
            Next
            If x(i, 1) = x(i + 1, 1) Then
                i = i + 1: iii = 3: iv = 1
                Do Until x(i, 1) <> x(i - 1, 1)
                    v = iii * iv
                    For ii = 2 To 4
                        y(vi, ii + v) = x(i, ii)
                    Next
                    i = i + 1: iv = iv + 1
                    If i > UBound(x, 1) Then Exit Do
                Loop
                i = i - 1
            End If
        Next
        .Clear
        .Value = y
    End With
    With ActiveSheet.ListObjects(1)
        For i = UBound(x, 1) To 1 Step -1
            If IsEmpty(y(i, 1)) Then .ListRows(i).Delete
        Next
        With .DataBodyRange
            .Columns(2).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;_-@_-"
            .Columns(5).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;_-@_-"
            .Columns(8).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;_-@_-"
            .Columns(11).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;_-@_-"
            .Columns(14).NumberFormat = "_-* #,##0.00 ""€""_-;-* #,##0.00 ""€""_-;_-* ""-""?? ""€""_-;_-@_-"
        End With
    End With
    
End Sub

Display More

clairexcel · Jul 4th 2022

Hi Kjbox, yeah I noticed the error this afternoon and I corrected it.

Afterwards it gave me error only with the items codes that initiated with a Letter e.g Y1245875.

The others e.g 2534789, it would do them correctly.

However thank you for the time and help, it is much appreciated. You helped me greatly.

thank you

**KjBox** · Jul 4th 2022

You're welcome

If dupplicate values found in column A - copy/paste range B:D of the dupplicates on the same row of the original value

Participate now!

Share

Similar Threads

Select and Export All Rows Between Two Different Cell Names, Loop

ProductSearch - Unhiding/Hiding Rows on Multiple Worksheets based on Column Value

pulling cell values from other workbooks (listed paths)

First row is automatically deleted after pasting data into sheet - bug?

Sum Cell Values Until Blank Cells With VBA

How to stop the main sub if a module gives an error.