Excel VBA macro to duplicate data if condition met - excel

this is really advanced level of macro for me. If anyone could help, i really appreciate it!
I have Data as below.
I want to write a macro that looks for the customerID, ex: if C2=C3, then i want it to look for either the row above or below using column D, fill either up or down (ColumnA, ColumnB, and ColumnD) based on how the data came out. Because the data may come out like Row A2 will be emptied or Row A3 will be emptied but each customer can ONLY have 2 row maxed of data lines.

I will answer based on my comment being true. If not it can be updated afterwards.
I simply just took the basics from my answer I gave yesterday and modified it to meet the conditions of this question. You should be able to see the differences and how easily you can change it to do these sort of tasks.
Sub AddMissingInfo()
Dim ws As Worksheet, lrow As Long, arr, i As Long, j As Long
Set ws = Sheets("Sheet1") 'Change to your sheet name
lrow = ws.Range("C" & ws.Rows.Count).End(xlUp).Row 'Use customerID to find last row, change column if needed
arr = ws.Range("A2:D" & lrow).Value 'Populate the array, change columns/starting row if needed
For i = 1 To UBound(arr, 1) - 1 'Stop loop at line before last (alas the -1)
If arr(i, 3) = arr(i + 1, 3) Then 'Check if customer ID matches the row below
If arr(i, 1) = "" Then 'Checks first name
If arr(i + 1, 1) <> "" Then arr(i, 1) = arr(i + 1, 1)
Else
If arr(i + 1, 1) = "" Then arr(i + 1, 1) = arr(i, 1)
End If
If arr(i, 2) = "" Then 'Checks last name
If arr(i + 1, 2) <> "" Then arr(i, 2) = arr(i + 1, 2)
Else
If arr(i + 1, 2) = "" Then arr(i + 1, 2) = arr(i, 2)
End If
If arr(i, 4) = "" Then 'Checks Order#
If arr(i + 1, 4) <> "" Then arr(i, 4) = arr(i + 1, 4)
Else
If arr(i + 1, 4) = "" Then arr(i + 1, 4) = arr(i, 4)
End If
End If
Next i
ws.Range("A2:D" & lrow).Value = arr 'Dump the info back to the range. Change columns/starting row if needed
End Sub

Related

Merge records with duplicate ID and combine different data

Here is a sample of data from my worksheet. It has been sorted in Column B from smallest to largest to show the duplicate Item Codes (highlighted yellow):
Here is a breakdown of the following columns:
Column A - ID, every ID is unique
Column B - Item Code, duplicates appear
Columns C to E - A range of different data, but if two records have the same Item Code (B), the rest of the data (C to E) will remain the same, as seen above
Columns F to L - Week numbers (52 in a year hence back to 1 in column K) contains numeric values. Despite multiple records could have the same Item Code (B), columns could contain different numeric values (notice the red marks in the above screenshot)
I want to merge these records, based on finding duplicate Item Codes (B), resulting in storing the first ID value (A), merging columns C to E and combing columns F to L. The screenshot below shows my desired output.
As you can see, the records have been combined and merged. Those with a red mark indicate how these numeric values have been added together to show a new value when there are 2 or more records with the same Item Code but have multiple numeric values in the same column. If there is only one value, it merges with the rest to create one row per Item Code.
I have looked online for a long time and all I could find was using Consolidate and using VBA code to combine these records in a format that didn't lead to this desired output, including using formulas.
Thank you!
Edit: The above has been answered. However, below is my original data, I thought the solution for the above question could be easily adjusted and applied to the original data, but I have found no luck with the following code:
Sub ConsolidateItemCodes()
Dim sh As Worksheet, destSh As Worksheet, lastR As Long, arr, arrH, arrVal, arrfin, arrIt
Dim i As Long, j As Long, k As Long, dict As Object
Set sh = Sheets("Sample of Original Data") 'use here the sheet you need processing
Set destSh = sh.Next 'use here the sheet where to return (now in the next sheet)
lastR = sh.Range("F" & sh.Rows.Count).End(xlUp).Row
arrH = sh.Range("A1:CO1").Value2 'the headers
arr = sh.Range("A2:CO" & lastR).Value2 'place the range in an array for faster iteration/processing
ReDim arrVal(0 To 36) 'redim the array keeping the values
'load the dictionary (ItemCodes as unique keys):
Set dict = CreateObject("Scripting.Dictionary") 'set the dictionary object
For i = 1 To UBound(arr)
If Not dict.Exists(arr(i, 6)) Then
For j = 0 To 36: arrVal(j) = arr(i, j + 36): Next j
dict.Add arr(i, 6), Array(Array(arr(i, 1), arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5), arr(i, 7), arr(i, 8), arr(i, 9), arr(i, 10), arr(i, 11), arr(i, 12), arr(i, 13), arr(i, 14), arr(i, 15), arr(i, 16), arr(i, 17), arr(i, 18), arr(i, 19), arr(i, 20), arr(i, 21), arr(i, 22), arr(i, 23), arr(i, 24), arr(i, 25), arr(i, 26), arr(i, 27), arr(i, 28), arr(i, 29), arr(i, 30), arr(i, 31), arr(i, 32), arr(i, 33), arr(i, 34), arr(i, 35)), arrVal)
Else
arrIt = dict(arr(i, 6)) 'a dictionary item can be adaptet directly, EXCEPT arrays...
For j = 0 To 36
arrIt(1)(j) = arrIt(1)(j) + arr(i, j + 36)
Next j
dict(arr(i, 6)) = arrIt 'place back the updated jagged array
End If
Next i
'process dictionary content
ReDim arrfin(1 To dict.Count + 1, 1 To UBound(arr, 6))
'place the header in the final array:
For i = 1 To UBound(arrH, 6): arrfin(1, i) = arrH(1, i): Next i
'extract data from dictionary:
k = 1
For j = 0 To dict.Count - 1
k = k + 1
arrIt = dict.Items()(j)
arrfin(k, 1) = arrIt(0)(0): arrfin(k, 2) = arrIt(0)(1): arrfin(k, 3) = arrIt(0)(2): arrfin(k, 4) = arrIt(0)(3): arrfin(k, 5) = arrIt(0)(4): arrfin(k, 6) = dict.keys()(j)
arrfin(k, 7) = arrIt(0)(5): arrfin(k, 8) = arrIt(0)(6): arrfin(k, 9) = arrIt(0)(7): arrfin(k, 10) = arrIt(0)(8): arrfin(k, 11) = arrIt(0)(9): arrfin(k, 12) = arrIt(0)(10): arrfin(k, 13) = arrIt(0)(11): arrfin(k, 14) = arrIt(0)(12): arrfin(k, 15) = arrIt(0)(13): arrfin(k, 16) = arrIt(0)(14): arrfin(k, 17) = arrIt(0)(15): arrfin(k, 18) = arrIt(0)(16): arrfin(k, 19) = arrIt(0)(17): arrfin(k, 20) = arrIt(0)(18): arrfin(k, 21) = arrIt(0)(19): arrfin(k, 22) = arrIt(0)(20): arrfin(k, 23) = arrIt(0)(21): arrfin(k, 24) = arrIt(0)(22): arrfin(k, 25) = arrIt(0)(23): arrfin(k, 26) = arrIt(0)(24): arrfin(k, 27) = arrIt(0)(25): arrfin(k, 28) = arrIt(0)(26): arrfin(k, 29) = arrIt(0)(27): arrfin(k, 30) = arrIt(0)(28): arrfin(k, 31) = arrIt(0)(29): arrfin(k, 32) = arrIt(0)(30): arrfin(k, 33) = arrIt(0)(31): arrfin(k, 34) = arrIt(0)(32): arrfin(k, 35) = arrIt(0)(33)
For i = 0 To 36: arrfin(k, i + 36) = arrIt(1)(i): Next i
Next j
'drop the processed array content at once:
With destSh.Range("A1").Resize(k, UBound(arrfin, 6))
.Value2 = arrfin
.Rows(1).Font.Bold = True
.EntireColumn.AutoFit
End With
MsgBox "Ready..."
End Sub
Here is a snippet of my original data. As you can see column A is the same, column B (2) above is actually column F (6), column F (6) is actually column AJ (36) and it ends at column CO (93).
And this is my desired output, similar to the above.
Please, test the next code. It returns (now) in the next sheet against the processed one, but you can set the destination sheet as you want. As I said in my above comment, it uses arrays and a dictionary and should be very fast. Records can be in any order:
Sub ConsolidateItemCodes()
Dim sh As Worksheet, destSh As Worksheet, lastR As Long, arr, arrH, arrVal, arrfin, arrIt
Dim i As Long, j As Long, k As Long, dict As Object
Set sh = ActiveSheet 'use here the sheet you need processing
Set destSh = sh.Next 'use here the sheet where to return (now in the next sheet)
If sh.FilterMode Then sh.ShowAllData 'to show all data in case of filters...
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
arrH = sh.Range("A1:L1").Value2 'the headers
arr = sh.Range("A2:L" & lastR).Value2 'place the range in an array for faster iteration/processing
ReDim arrVal(0 To 6) 'redim the array keeping the values
'load the dictionary (ItemCodes as unique keys):
Set dict = CreateObject("Scripting.Dictionary") 'set the dictionary object
For i = 1 To UBound(arr)
If Not dict.Exists(arr(i, 2)) Then
For j = 0 To 6: arrVal(j) = arr(i, j + 6): Next j
dict.Add arr(i, 2), Array(Array(arr(i, 1), arr(i, 3), arr(i, 4), arr(i, 5)), arrVal)
Else
arrIt = dict(arr(i, 2)) 'a dictionary item can be adaptet directly, EXCEPT arrays...
For j = 0 To 6
arrIt(1)(j) = arrIt(1)(j) + arr(i, j + 6)
Next j
dict(arr(i, 2)) = arrIt 'place back the updated jagged array
End If
Next i
'process dictionary content
ReDim arrfin(1 To dict.count + 1, 1 To UBound(arr, 2))
'place the header in the final array:
For i = 1 To UBound(arrH, 2): arrfin(1, i) = arrH(1, i): Next i
'extract data from dictionary:
k = 1
For j = 0 To dict.count - 1
k = k + 1
arrIt = dict.Items()(j)
arrfin(k, 1) = arrIt(0)(0): arrfin(k, 2) = dict.keys()(j)
arrfin(k, 3) = arrIt(0)(1): arrfin(k, 4) = arrIt(0)(2): arrfin(k, 5) = arrIt(0)(3)
For i = 0 To 6: arrfin(k, i + 6) = arrIt(1)(i): Next i
Next j
'drop the processed array content at once:
With destSh.Range("A1").Resize(k, UBound(arrfin, 2))
.Value2 = arrfin
.rows(1).Font.Bold = True
.EntireColumn.AutoFit
End With
MsgBox "Ready..."
End Sub
I tried commenting all code lines, to be easy understood. If something still not clear enough, do not hesitate to ask for clarifications.
Please, send some feedback after testing it.
Option Explicit
Sub aggregate()
Const ITEM_CODE = "F" ' Item Code
Const WK1 = "AJ" ' start of numeric data
Dim wb As Workbook, ws As Worksheet, n As Long, c1 As Long, c2 As Long
Dim c As Long, r As Long, lastrow As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
Application.ScreenUpdating = False
With ws
lastrow = .Cells(.Rows.Count, ITEM_CODE).End(xlUp).Row
' start and end columns
c1 = .Columns(WK1).Column
c2 = .UsedRange.Columns.Count + .UsedRange.Column - 1
' scan up sheet
For r = lastrow To 3 Step -1
' compare with row above
If .Cells(r, ITEM_CODE) = .Cells(r - 1, ITEM_CODE) Then
For c = c1 To c2
' aggregate if not blank
If Cells(r, c) <> "" Then
.Cells(r - 1, c) = .Cells(r - 1, c) + .Cells(r, c)
End If
Next
'.Rows(r).Interior.ColorIndex = 3
.Rows(r).Delete
n = n + 1
End If
Next
End With
Application.ScreenUpdating = True
MsgBox n & " rows deleted", vbInformation
End Sub

How to delete Duplicate values in a column but only between the empty rows in VBA?

Sample data: Click to get image
I need to delete duplicate values in the column for Distance, that is column I. There are empty rows between each group.
I want to keep just the topmost value present in each group. Note that the column may have similar values in different groups that shouldn't be deleted.
Here is what I tried. But it deletes useful values if the value is the same between different groups(as code would but that's not what I want).
Dim colJ As Range
Set colJ = ActiveSheet.UsedRange.Columns("J")
For i = 2 To lr
If .Cells(i, 11) = .Cells(i - 1, 11) Then
.Cells(i, 11) = ""
End If
If .Cells(i, 11) = .Cells(i + 2, 11) Then
.Cells(i + 2, 11) = ""
End If
If .Cells(i, 11) = .Cells(i + 3, 11) Then
.Cells(i + 3, 11) = ""
End If
If .Cells(i, 11) = .Cells(i + 4, 11) Then
.Cells(i + 4, 11) = ""
End If
If .Cells(i, 11) = .Cells(i + 5, 11) Then
.Cells(i + 4, 11) = ""
End If
Next i
Please, try the next code:
Sub DeleteGroupDuplicates()
Dim sh As Worksheet, lastRow As Long, rng As Range, A As Range
Set sh = ActiveSheet 'use here the necessary sheet
lastRow = sh.Range("I" & sh.rows.Count).End(xlUp).row 'last row of "I:I"
'create a discontinuous range, in order to create areas between empty rows:
Set rng = sh.Range("I2:I" & lastRow).SpecialCells(xlCellTypeConstants)
For Each A In rng.Areas 'iterate between all areas (intervals between empty rows)
A.UnMerge
A.RemoveDuplicates Columns:=1, Header:=xlNo 'remove duplicates, no header...
Next
End Sub

How to reconfigure lists located in separate columns by way of alternating the columns being transferred for each row?

I have a data set that consists of columns A-D. Values in A and D are the same respectively, as are B and C. It is listed for the purposes of A correlating to B, and C to D. What I would like to do is to be able to create a new two column list using the combinations of A&B and C&D. But I need them to go in the order they are originally listed i.e. new sheet, Row 1 A&B, Row 2 C&D, Row 3 A&B etc.
At first I tried simple filters and sorting, but due to the range of the data set at times, it makes the values that need to be close too each other too far. I tried a few failed splices and cuts. I had hoped there would just be a built in excel function.
Option Explicit
Sub combineList()
Dim i As Long
Dim lRow As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
If Cells(i, 1) = "" Then
'do nothing
Else
If Cells(i, 9) = "" Then
Cells(i, 9) = Cells(i, 1)
Cells(i, 10) = Cells(i, 2)
Cells(i + 1, 9) = Cells(i, 4)
Cells(i + 1, 10) = Cells(i, 5)
Else
i = i + 1
Cells(i, 9) = Cells(i, 1)
Cells(i, 10) = Cells(i, 2)
Cells(i + 1, 9) = Cells(i, 4)
Cells(i + 1, 10) = Cells(i, 5)
'i = i - 1
End If
End If
Next i
End With
End Sub
First attempt, trying to get it to skip over rows for C&D.
Sub newMethod()
Dim i As Long
Dim j As Long
Dim lRow As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("a" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow Step -1
If Cells(i, 1) = "" Then
'do nothing
Else
Cells(i, 9) = Cells(i, 1)
Cells(i, 10) = Cells(i, 2)
'i = i + 1
End If
Next i
For j = 2 To lRow Step 2
If Cells(j, 1) = "" Then
'do nothing
Else
Cells(j + 1, 9) = Cells(j, 4)
Cells(j + 1, 10) = Cells(j, 5)
'j = j + 1
End If
Next j
End With
End Sub
As stated above, to be able to reorganize the list by "shuffling" it together. Basically each row split into two. My attempts have ended with loops that just constantly overwrite themselves.
You can obtain your desired results using formulas.
It is a matter of deriving the mathematics of obtaining the correct row/col numbers in sequence.
F2: =INDEX($A:$D,FLOOR(ROWS($1:2)/2,1)+1,MOD(ROWS($1:2),2)*2+1)
G2: =INDEX($A:$D,FLOOR(ROWS($1:2)/2,1)+1,MOD(ROWS($1:2),2)*2+2)

Excel merge similar rows and sum cells

what would be the best way to merge similar rows (only order number letter different a4;a6;a8 and produced quantity) and sum (produced quantity e4;e6;e8) cells? This is how excel table looks
Clarification:
Here is the output I'm looking for
Rows 4;6;8 are the same except Order column (one letter added on 6 and 8) and Produced Column (different produced quantity). Rows 4,6,8 are merged and produced quantity is summed. Rows 6,8 is hidden or deleted.
Here is an example that could solve your problem:
Sub test()
i = 1
produced = 0
While Cells(i, 1) <> "" Or Cells(i + 1, 1) <> ""
If Cells(i, 1) <> "" Then
produced = Cells(i, 5)
j = 1
'second loop to add up every line with the same order, then suppress the lines
While Cells(j, 1) <> "" Or Cells(j + 1, 1) <> ""
If Left(Cells(j, 1), 7) = Left(Cells(i, 1), 7) And i <> j Then
produced = produced + Cells(j, 5)
Cells(j, 5).EntireRow.Select
Selection.Delete Shift:=xlUp
j = j - 1
End If
j = j + 1
Wend
End If
i = i + 1
Wend
Ok, here is the modified #Bitoubi code which helped me:
Sub RemoveSplitOrders()
i = 1
produced = 0
While Cells(i, 1) <> "" Or Cells(i + 1, 1) <> ""
If Cells(i, 1) <> "" Then
produced = Cells(i, 20)
j = 1
'second loop to add up every line with the same order, then suppress the lines
While Cells(j, 1) <> "" Or Cells(j + 1, 1) <> ""
If Left(Cells(j, 1), 8) = Left(Cells(i, 1), 8) Or Left(Cells(j, 1), 9) = Left(Cells(i, 1), 9) Then
If Cells(j, 2) = Cells(i, 2) And i <> j Then
produced = produced + Cells(j, 20)
Cells(i, 20).Value = produced
Range(Cells(j, 20), Cells(j + 1, 20)).EntireRow.Delete Shift:=xlUp
j = j - 1
End If
End If
j = j + 1
Wend
End If
i = i + 1
Wend
End Sub

Excel macro that combines cells and deletes duplicates

I'm trying to locate a macro that would do the following:
1) Go through Column C to locate identical values.
2) If there are identical values in column C and the values in column A are different, put both of those values into column A.
The coding below appears to be close to what I'd like. Such as, deleting the duplicate rows and combining the cells. However, it is not combining the correct cells.
So for example, on rows 65 & 66 I'd like for there to be only 1 row for "CLAIM_NO" 525533564 with "2325 / 2337" in cell A
Sub test()
Dim i As Long
For i = Cells(Rows.Count, "C").End(xlUp).Row To 2 Step -1
If Cells(i, "C") = Cells(i - 1, "C") Then
Cells(i - 1, "A") = Cells(i - 1, "A") & " / " & Cells(i - 1, "A")
Rows(i).Delete
End If
One tiny problem in the original code:
Sub test()
Dim i As Long
For i = Cells(Rows.Count, "C").End(xlUp).Row To 2 Step -1
If Cells(i, "C") = Cells(i - 1, "C") Then
Cells(i - 1, "A") = Cells(i - 1, "A") & " / " & Cells(i, "A")
Rows(i).Delete
End If
Next i
End Sub

Resources