How to combine data from multiple rows when common column headings exist? - vba

Question

I have a fairly large data-set that needs to be exported as CSV from Excel for import into another application. It can not have duplicate column headings but at this time there are many instances of that happening. I need to consolidate these headings and their respective data into single columns and remove duplicates.
I am trying to take data like this:
MAKE | MAKE | MAKE | MODEL | MODEL | TRIM |
-------------------------------------------
FORD | | | | | |
-------------------------------------------
| FIAT | | | | |
-------------------------------------------
| | MINI | | | |
-------------------------------------------
| | | PILOT | | |
-------------------------------------------
| | | | SC400 | |
-------------------------------------------
| | | | | EX |
-------------------------------------------
and turn it into this:
MAKE | MODEL | TRIM |
---------------------
FORD | | |
---------------------
FIAT | | |
---------------------
MINI | | |
---------------------
| PILOT | |
---------------------
| SC400 | |
---------------------
| | EX |
---------------------
Thanks in advance for any help in accomplishing this.

Answer 1

You need to separate the problem in smaller bits:
Read the unique titles and save them in a Dictionary object (as a value you might want to hold on the column they are going to be saved in)
You iterate through each cell getting the value and reading the column header.
You write that value in a new sheet on the column you are currently iterating through but for column position you look-up the current column title in the dictionary and get its position.
EDIT: Code tested and debugged. Works well.
Note: This method assumes that you have only 1 value per duplicated columns per row.
If you have more than 1 value for duplicated columns then the program will always save the last one (as it will overwrite the previous value). If you want a method that handles multiple values per column then you need to keep a Row number for each column in the new sheet and increment it by 1 each time you write data in that column.
Sub WriteValues()
'Aassuming your column titles are in row 1
Dim mainSheet As Worksheet
Set mainSheet = ActiveSheet
Dim maxCols As Integer
Dim maxRows As Double
maxRows = 0
maxCols = Cells(1, Columns.Count).End(xlToLeft).Column
Dim colPositions As Dictionary
Set colPositions = New Dictionary
'Iterate throgh row 1 to get all uniue values
Dim iCol As Integer
For iCol = 1 To maxCols
On Error Resume Next
colPositions.Add Cells(1, iCol).Value, colPositions.Count + 1
On Error GoTo 0
'Also record maxRows
If Cells(rows.Count, iCol).rows.End(xlUp).row > maxRows Then
maxRows = Cells(rows.Count, iCol).rows.End(xlUp).row
End If
Next i
Dim newSheet As Worksheet
Set newSheet = Sheets.Add
Dim col As Integer
Dim row As Double
'Write column titles in new sheet
Dim v As Variant
iCol = 1
For Each v In colPositions
Cells(1, iCol).Value = v
iCol = iCol + 1
Next v
'Main data iterator
For row = 2 To maxRows
For col = 1 To maxCols
Dim cellValue As String
Dim valueColumn As String
With mainSheet
cellValue = .Cells(row, col).Value
valueColumn = .Cells(1, col).Value
End With
If cellValue <> "" Then
newSheet.Cells(row, colPositions(valueColumn)).Value = cellValue
End If
Next col
Next row
End Sub