I have been currently working on a problem for the last few days, using a number of resources throughout this fantastic site and others - mixing and merging code to try and achieve (what I think is a unique problem) but have not quite landed successfully on a solution.
I currently take output in the form of a .csv (varying length of rows) however the columns (and their order) remain constant - this .csv will then run through a macro (just been converting the .csv to .xlsm and adding a module in) to produce the desired result. Currently I have 50 columns, of which the a number of rows are duplicates with only the end columns changing - what I would like to do is merge the duplicate rows, but keep the unique cells (and where I am falling flat - is they keep their format and location).
Now that I've successfully confused you all haha - here's a visual aid
.
Current:
Desired:
Hopefully the above makes sense - everything I've come across/found/tried has resulted in the duplicates being merged fine but the unique values all being merged with commas, spaces and so on - I need the unique values to keep their line format so they can be read correctly. If they are all merged into the same cell and separated with comma or alike, it becomes very hard to make sense.
Some code that may assist that I've tried piecing together:
Merges Rows based on specifics - separator for non-duplicates is vblf - this is quite close but doesn't keep formatting/lines (credit: Tony Dallimore)
Simply merges rows based on A2 range - I've tried fiddling with this to sort on A2:* range but no luck:
Thanks so much!
-XG
I currently take output in the form of a .csv (varying length of rows) however the columns (and their order) remain constant - this .csv will then run through a macro (just been converting the .csv to .xlsm and adding a module in) to produce the desired result. Currently I have 50 columns, of which the a number of rows are duplicates with only the end columns changing - what I would like to do is merge the duplicate rows, but keep the unique cells (and where I am falling flat - is they keep their format and location).
Now that I've successfully confused you all haha - here's a visual aid
.Current:
Desired:
Hopefully the above makes sense - everything I've come across/found/tried has resulted in the duplicates being merged fine but the unique values all being merged with commas, spaces and so on - I need the unique values to keep their line format so they can be read correctly. If they are all merged into the same cell and separated with comma or alike, it becomes very hard to make sense.
Some code that may assist that I've tried piecing together:
Merges Rows based on specifics - separator for non-duplicates is vblf - this is quite close but doesn't keep formatting/lines (credit: Tony Dallimore)
Code:
Sub MergeRows()
' Merges adjacent rows for which all columns listed in ColMatch are equal
' by appending the contents of the other columns from the second row to
' the first row and then deleting the second row.
Dim CheckOK As Boolean
Dim ColCrnt As Long
Dim ColLast As Long
Dim ColMatch() As Variant
Dim ColMerge() As Variant
Dim InxMatch As Long
Dim InxMerge As Long
Dim RowCrnt As Long
Dim RowLast As Long
Dim RowsMatch As Boolean
Dim TimeStart As Single
' Defines the first row to be considered for merging. This avoids
' looking at header rows (not very important) and allows a restart
' from row 600 or whatever (might be important).
Const rowDataFirst As Long = 2
' Defines the string to be placed between the value in the first row
' and the value from the second row.
Const Separator As String = vbLf
' Speeds up processing
Application.ScreenUpdating = False
' Stops the code from being interrupted by event routines
Application.EnableEvents = False
' Use status bar as a progress indicator
Application.DisplayStatusBar = True
' Record seconds since midnight at start of routine.
TimeStart = Timer
' Defines the columns which must have the same values in two
' adjacent rows for the second row to be merged into the
' first row. Column numbers must be in ascending order.
ColMatch = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21)
' Defines the columns for which values from the second row
' are to be appended to the first row of a matching pair.
' Column numbers must be in ascending order. ColMatch and
' ColMerge together must specify every used column.
ColMerge = Array(22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47)
' Replace "Merge" with the name of your worksheet
With Worksheets("Sheet1")
' Find last used column and last used row
ColLast = .Cells.Find("*", .Range("A1"), xlFormulas, xlWhole, _
xlByColumns, xlPrevious).Column
RowLast = .Cells.Find("*", .Range("A1"), xlFormulas, xlWhole, _
xlByRows, xlPrevious).Row
' Validate column parameters. Every column must be specified once
' in either ColMatch or ColMerge.
InxMatch = 0 ' 0 = lower bound of array
InxMerge = 0
For ColCrnt = 1 To ColLast
CheckOK = False ' Set true if check successful
If InxMatch > UBound(ColMatch) Then
' ColMatch array exhausted
Else
If ColCrnt = ColMatch(InxMatch) Then
CheckOK = True
InxMatch = InxMatch + 1
End If
End If
If Not CheckOK Then
If InxMerge > UBound(ColMerge) Then
' ColMerge array exhausted
Else
If ColCrnt = ColMerge(InxMerge) Then
CheckOK = True
InxMerge = InxMerge + 1
End If
End If
End If
If Not CheckOK Then
Call MsgBox("I was unable to find column " & ColCrnt & " in either" & _
" ColMatch or ColMerge. Please correct and try again.", _
vbOKOnly)
Exit Sub
End If
Next
RowCrnt = rowDataFirst
Do While True
If RowCrnt Mod 100 = 0 Then
' Use status bar to indicate progress
Application.StatusBar = "Row " & RowCrnt & " of " & RowLast
End If
' Attempt to match RowCrnt and RowCrnt+1
RowsMatch = True ' Assume match until find otherwise
For InxMatch = 0 To UBound(ColMatch)
ColCrnt = ColMatch(InxMatch)
If .Cells(RowCrnt, ColCrnt).Value <> _
.Cells(RowCrnt + 1, ColCrnt).Value Then
' Rows do not match
RowsMatch = False
Exit For
End If
Next
If RowsMatch Then
' Rows match. Merge second into first.
For InxMerge = 0 To UBound(ColMerge)
ColCrnt = ColMerge(InxMerge)
.Cells(RowCrnt, ColCrnt).Value = .Cells(RowCrnt, ColCrnt).Value & _
Separator & _
.Cells(RowCrnt + 1, ColCrnt).Value
Next
' Second row merged into first. Discard second row.
.Rows(RowCrnt + 1).EntireRow.Delete
' RowLast has moved up.
RowLast = RowLast - 1
' Do not step RowCrnt because there may be another match for it
If RowCrnt = RowLast Then
' All rows checked.
Exit Do
End If
Else
' Rows do not match. RowCrnt no longer of interest.
RowCrnt = RowCrnt + 1
If RowCrnt = RowLast Then
' All rows checked.
Exit Do
End If
End If
Loop
End With
' Output duration of macro to Immediate window
Debug.Print Format(Timer - TimeStart, "#,##0.00")
Application.StatusBar = False
Application.EnableEvents = True
Application.ScreenUpdating = True
End SubSimply merges rows based on A2 range - I've tried fiddling with this to sort on A2:* range but no luck:
Code:
Sub test()
Dim a, i As Long, ii As Long, n As Long, z As String, x As Long
a = Sheets("Sheet1").Range("a2").CurrentRegion.Value
n = 1
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 2 To UBound(a, 1)
For ii = 2 To 11
z = z & Chr(2) & a(i, ii)
Next
If Not .exists(z) Then
n = n + 1: .Item(z) = n
For ii = 1 To UBound(a, 2)
a(n, ii) = a(i, ii)
Next
Else
x = .Item(z)
For ii = 12 To UBound(a, 2)
If a(i, ii) <> "" Then
a(x, ii) = a(x, ii) & IIf(a(x, ii) <> "", ",", "") & a(i, ii)
End If
Next
End If
z = ""
Next
End With
On Error Resume Next
Application.DisplayAlerts = False
Sheets("result").Delete
On Error GoTo 0
Sheets.Add().Name = "Result"
With Sheets("result").Cells(1).Resize(n, UBound(a, 2))
.Value = a
.EntireColumn.AutoFit
End With
End SubThanks so much!
-XG
