Remove rows based on duplicates in certain columns, and merge data from another column

Hi,

I'm new to VBA...

In the example attached, I would like to run a macro so that whenever there's duplicate data in column A(approved Date), C(Total number of attendees), and E(full expense dollars) - I need them to be based on Header titles, not Column names in the VBA script -the macro will remove the duplicated rows and only keep one, and merge the data(employee names) from column D before removing the duplicate rows.

Can anyone help please.

Thank you very much.

Hi

Try this.

Sub aaa()
  Dim AD As Long, TNOA As Long, EN As Long, FED As Long
  Set dic = CreateObject("Scripting.dictionary")
  AD = WorksheetFunction.Match("Approved Date", Rows("1:1"), 0)
  TNOA = WorksheetFunction.Match("Total Number of Attendees", Rows("1:1"), 0)
  EN = WorksheetFunction.Match("Employee Name", Rows("1:1"), 0)
  FED = WorksheetFunction.Match("Full Expense Dollars", Rows("1:1"), 0)
  
  For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    If Not dic.exists(Cells(i, AD) & "," & Cells(i, TNOA) & "," & Cells(i, FED)) Then
      dic.Add Item:=Cells(i, AD) & "," & Cells(i, TNOA) & "," & Cells(i, FED) & "," & i, Key:=Cells(i, AD) & "," & Cells(i, TNOA) & "," & Cells(i, FED)
    Else
      arr = Split(dic(Cells(i, AD) & "," & Cells(i, TNOA) & "," & Cells(i, FED)), ",")
      Cells(arr(3), EN).Value = Cells(arr(3), EN).Value & "; " & Cells(i, EN)
      Cells(i, 1).Resize(1, 5).ClearContents
    End If
  Next i
  
  For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
    If Len(Cells(i, 1)) = 0 Then Cells(i, 1).EntireRow.Delete shift:=xlUp
  Next i
  
End Sub

rylo

Thank you so much rylo!!! You script did exactly what I needed.

There is only one small problem when I ran the script using the attached example(Book2 R1.xlsm). Please see the Result tab, after running the script on the Example worksheet, I got extra few rows that are supposed to be removed but they are not. Could you help me diagnose where the problem is? Thank you again~ !!

Sorry it's me again, it seems like the "Approved Date" has to be in the first column (column A) so that the script would run. What if I have other miscellaneous columns in front of the Approved Date?

Thank you once again.

Hi

Couple of small changes. See how this goes.

Sub aaa()
  Dim AD As Long, TNOA As Long, EN As Long, FED As Long, LastCol As Long
  Set dic = CreateObject("Scripting.dictionary")
  AD = WorksheetFunction.Match("Approved Date", Rows("1:1"), 0)
  TNOA = WorksheetFunction.Match("Total Number of Attendees", Rows("1:1"), 0)
  EN = WorksheetFunction.Match("Employee Name", Rows("1:1"), 0)
  FED = WorksheetFunction.Match("Full Expense Dollars", Rows("1:1"), 0)
  LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
  
  Application.ScreenUpdating = fause
  
  For i = 2 To Cells(Rows.Count, AD).End(xlUp).Row
    If Not dic.exists(Cells(i, AD) & "," & Cells(i, TNOA) & "," & Cells(i, FED)) Then
      dic.Add Item:=Cells(i, AD) & "," & Cells(i, TNOA) & "," & Cells(i, FED) & "," & i, Key:=Cells(i, AD) & "," & Cells(i, TNOA) & "," & Cells(i, FED)
    Else
      arr = Split(dic(Cells(i, AD) & "," & Cells(i, TNOA) & "," & Cells(i, FED)), ",")
      Cells(arr(3), EN).Value = Cells(arr(3), EN).Value & "; " & Cells(i, EN)
      Cells(i, 1).Resize(1, LastCol).ClearContents
    End If
  Next i
  
  For i = Cells(Rows.Count, AD).End(xlUp).Row To 2 Step -1
    If Len(Cells(i, 1)) = 0 Then Cells(i, 1).EntireRow.Delete shift:=xlUp
  Next i
 Application.ScreenUpdating = True
 
End Sub

rylo

Hi Rylo,

Thank you so much again!

I tried the revised VBA and it looks like it works correctly when the "Approved Date" is in Column A, and it erases data if I have other columns infront of the Approved Date. In my actual case I will have 2 additional columns in front of the Approved Date. Can you help again. Sorry for the trouble~

Hi

Put up an example file of the structure that is causing you problems.

rylo

Hi Rylo,

Please see file attached (Book2 R2.xlsm). First tab is the example and second tab is the result in this case. Thank you again.

Hi

OK, another go

Sub bbb()
  Dim AD As Long, TNOA As Long, EN As Long, FED As Long, LastCol As Long
  Set dic = CreateObject("Scripting.dictionary")
  AD = WorksheetFunction.Match("Approved Date", Rows("1:1"), 0)
  TNOA = WorksheetFunction.Match("Total Number of Attendees", Rows("1:1"), 0)
  EN = WorksheetFunction.Match("Employee Name", Rows("1:1"), 0)
  FED = WorksheetFunction.Match("Full Expense Dollars", Rows("1:1"), 0)
  LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
  
  Application.ScreenUpdating = False
  
  For i = 2 To Cells(Rows.Count, AD).End(xlUp).Row
    If Not dic.exists(Cells(i, AD) & "," & Cells(i, TNOA) & "," & Cells(i, FED)) Then
      dic.Add Item:=Cells(i, AD) & "," & Cells(i, TNOA) & "," & Cells(i, FED) & "," & i, Key:=Cells(i, AD) & "," & Cells(i, TNOA) & "," & Cells(i, FED)
    Else
      arr = Split(dic(Cells(i, AD) & "," & Cells(i, TNOA) & "," & Cells(i, FED)), ",")
      Cells(arr(3), EN).Value = Cells(arr(3), EN).Value & "; " & Cells(i, EN)
      Cells(i, 1).Resize(1, LastCol).ClearContents
    End If
  Next i
  
  For i = Cells(Rows.Count, AD).End(xlUp).Row To 2 Step -1
    If Len(Cells(i, AD)) = 0 Then Cells(i, 1).EntireRow.Delete shift:=xlUp
  Next i
 Application.ScreenUpdating = True
 
End Sub

rylo

Thank you sooooooo much Rolo!!! Works perfectly!!!! Thank you!

@ yanagi600

Welcome to the forum.

Based on your last post it seems that you are satisfied with the solution(s) you've received but you haven't marked your thread as SOLVED. I'll do that for you now but please keep in mind for your future threads that Rule #9 requires you to do that yourself. If your problem has not been solved you can use Thread Tools (located above your first post) and choose "Mark this thread as unsolved".
Thanks.

Also, as a new member of the forum, you may not be aware that you can thank those who have helped you by clicking the small star icon located in the lower left corner of the post in which the help was given. By doing so you can add to the reputation(s) of those who helped.

Thank you for the reminder Gutter. I've just added a positive reputation to Rylo, and will remember to mark thread as SOLVED in the future. Thanks again!

Hi Rylo and everyone,

it's me again.
Just one very quick question in the scripts sub bbb() provided above. Within the If Else section, what does the "arr()" do? And should I modify the number for the arr if my conditions(AD, TNOA, EN, etcx) have increased/decreased?

Thanks in advance for your help.

Hi

The arr() splits out the dictionary item, for the relevant key, to get the row number of the first appearance of the matching item. It is the 4th subpart, with each subpart separated by a comma, and with the array starting from 0, it will be in position 3. So if you are going to increase / decrease the criteria used to select your items of interest, you will not only have to alter the array position, but the key for the dictionary object, and the item in the dictionary object.

Clear as mud isn't it! :-)

rylo

Hi Rylo, I was on a vacation and just saw your response. Thank you so much for your prompt help always.

Just would like to make sure that I understand this correctly - if I need to add an additional condition such as "Approver Name" and declare it as AN as an example, add it to the dictionary object, and put it after "FED". In this case, does it mean that the arry(3) should stay as is, since the position of the "EN" subpart has not been changed in the dictionary object?

Thank you!!!

yanagi600