Remove duplicate rows but retain data in three columns using Excel 2007 - vba

Question

I will be importing an Excel 2007 file into Access 2007, but before I do that, I must massage the Excel file, as follows:
1.) Remove duplicate rows associated with numeric data in column A.
2.) I need to retain the data in three columns (columns I, P and Q), and combine that alpha numeric data, semi-colon separated, in the retained rows cells of columns I, P and Q.
3.) If any data in columns I, P and Q from the duplicate rows already exists, then do not retain that duplicated data
From This...
To This...
I'd be eternally grateful for assistance here. Kinda got pulled into this "mini-project" because I knew what Excel and Access were. Nice. :)

Answer 1

hoping to deserve that eternal gratitude...
open your worksheet with data, press ALT+F11 to launch the IDE and click Insert->Module. this will add a "Module" in your VBA "Project"
in the "Project Manager Window" (click View-> "Project Manager Window" to possibly show it) double click over the "Module1" node to open the module code pane and place this code in it
Option Explicit
Sub RemoveDupesAndRetainData()
Dim cell As Range
Dim nDupes As Long
With ActiveWorkbook.Worksheets("Data") '<~~ change sheet name as per your needs
With .Range("A1:Q" & .Cells(.Rows.Count, 1).End(xlUp).Row) '<~~ data are in columns A to P and start from row 1 (headers)
.Sort key1:=.Range("A1"), order1:=xlAscending, Header:=xlYes '<~~ sort rows by "Order"
For Each cell In .Offset(1).Resize(, 1).SpecialCells(xlCellTypeConstants) '<~~ loop through each cell in columns A containing values
nDupes = WorksheetFunction.CountIf(.Columns(1), cell.Value) - 1 '<~~ count duplicates
If nDupes > 0 Then '<~~ if there are any ...
.AutoFilter Field:=1, Criteria1:=cell.Value '<~~ ...filter data by "order" as current cell content -> only rows with same current cell content will be displayed...
With .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible) ''<~~ ...consider only visible cells of data range, skipping headers row...
Intersect(cell.EntireRow, .Columns("I")).Value = Join(Application.Transpose(Intersect(.Cells, .Columns("I").EntireColumn)), ";") ' ...concatenate "Resource" field...
Intersect(cell.EntireRow, .Columns("P")).Value = Join(Application.Transpose(Intersect(.Cells, .Columns("P").EntireColumn)), ";") ' ...concatenate "Special" field...
Intersect(cell.EntireRow, .Columns("Q")).Value = Join(Application.Transpose(Intersect(.Cells, .Columns("Q").EntireColumn)), ";") ' ...concatenate "Notes" field...
cell.Offset(1).Resize(nDupes).EntireRow.Delete '<~~ delete duplicate rows
End With
.AutoFilter '<~~ remove filters
End If
Next cell
End With
End With
End Sub
back to Excel UI, press Alt+F8 to have the Macro dialog box pop out
select "RemoveDupesAndRetainData" in the combobox and then press the "Execute" button
watch what happens... in case of errors you can press "Debug" button in the error message box to throw you in the VBA editor right at the line causing the error
another way of running the macro is the following:
in the VBA IDE (ALT+F11 from Excel UI) module code pane (double click on the wanted Module node in the Project Manager Window ) place the mouse cursor in any point between Sub RemoveDupesAndRetainData and End Sub statements and press F8 to have your macro start with its first line yellow shaded
now press F8 to step through each code line that will be executed and that will yellow shaded as well
at every step you can query every variable value by hovering the mouse over any of its occurrence within the code or by typing ? variable_name in the Immediate Window (that you can visualize by clicking "Ctrl+G" or selecting View->Immediate Window)
placing the mouse cursor within any significative code "word" and pressing "F1" will launch the relevant help topic to learn about that specific object. each topic will have hyperlinks to dig into and get more corresponding info
of course the web is another invaluable knowledge source where to find almost everything you currently need, with dozens of blogs specific to Excel and VBA
I think what above will get you started and, more important, going on
it's a long way but everybody here who's helping coding fellows started like that, and never reached the end of it

Answer 2

Additional variant from my side:
Sub test()
Dim cl As Range, Data As Range, key$, item$, k
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Dic.CompareMode = vbTextCompare
With Sheets("SheetName") 'specify Sheet Name
Set Data = .Range("A2:Q" & .[A:A].Find("*", , , , xlByRows, xlPrevious).Row)
Data.RemoveDuplicates Array(1, 9, 16, 17), xlYes
End With
For Each cl In Data.Columns(1).Cells
key = cl.Value2
item = cl.Offset(, 8).Value2 & "|" & cl.Offset(, 15).Value2 & "|" & cl.Offset(, 16).Value2
If Not Dic.exists(key) Then
Dic.Add key, item
Else
Dic(key) = Split(Dic(key), "|")(0) & ";" & Chr(10) & Split(item, "|")(0) & "|" & _
Split(Dic(key), "|")(1) & ";" & Chr(10) & Split(item, "|")(1) & "|" & _
Split(Dic(key), "|")(2) & ";" & Chr(10) & Split(item, "|")(2) & "|"
End If
Next cl
Data.RemoveDuplicates (1), xlYes
For Each k In Dic
If Dic(k) Like "*;*" Then
Set cl = Data.Columns(1).Find(k)
With cl
.Offset(, 8).Value2 = Split(Dic(k), "|")(0)
.Offset(, 15).Value2 = Split(Dic(k), "|")(1)
.Offset(, 16).Value2 = Split(Dic(k), "|")(2)
End With
End If
Next k
End Sub
before:
after: