PDA

View Full Version : Combining Rows



john3j
03-20-2015, 05:07 PM
I am trying to figure out how to write VBA that would combine rows in an Excel spreadsheet. If you look at the attachment, you will see a table in the "Before" worksheet. Basically, if there are duplicate lines that have the same contents, I want the VBA to remove the duplicate lines and add all of the affected computers in one cell, separated by a line. The end result should look like what is in the "After" worksheet. I am assuming I would need to do a loop through a range in the first column, but I honestly do not work with VBA anymore. I would appreciate any help!

Please see the attachment if you are willing to help.

apo
03-23-2015, 12:24 AM
Spaghetti anyone?



Private Sub CommandButton1_Click()
Dim x, y, LR As Long, i As Long, cnt As Long
With Range("A1").CurrentRegion
x = .Offset(1).Resize(.Rows.Count - 1).Value
LR = .Rows.Count: cnt = 1
ReDim y(1 To Application.Evaluate("=SUMPRODUCT((A2:A" & LR & "<>"""")/COUNTIF(A2:A" & LR & ",A2:A" & LR & "&""""))"), 1 To 2)
For i = 2 To UBound(x)
If x(i, 1) = x(i - 1, 1) Then
y(cnt, 1) = x(i, 1): y(cnt, 2) = y(cnt, 2) & Chr(32) & x(i - 1, 2)
ElseIf i = UBound(x) Then
y(cnt, 1) = x(i - 1, 1)
y(cnt, 2) = Replace(Trim(y(cnt, 2)) & Chr(32) & x(i - 1, 2), Chr(32), vbLf)
cnt = cnt + 1
y(cnt, 1) = x(i, 1)
y(cnt, 2) = Replace(Trim(y(cnt, 2)) & Chr(32) & x(i, 2), Chr(32), vbLf)
Else
y(cnt, 1) = x(i - 1, 1)
y(cnt, 2) = Replace(Trim(y(cnt, 2)) & Chr(32) & x(i - 1, 2), Chr(32), vbLf)
cnt = cnt + 1
End If
Next i
.Offset(1, 4).Resize(UBound(y)).Value = y
End With
End Sub

Bob Phillips
03-23-2015, 02:05 AM
Penne?


Public Sub CombineRows()
Dim lastrow As Long
Dim i As Long

Application.ScreenUpdating = False

With ActiveSheet

lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = lastrow To 2 Step -1

If .Cells(i, "A").Value = .Cells(i - 1, "A").Value Then

.Cells(i - 1, "B").Value = .Cells(i - 1, "B").Value & vbLf & .Cells(i, "B").Value
.Rows(i).Delete
End If
Next i
End With

Application.ScreenUpdating = True
End Sub

apo
03-23-2015, 02:42 AM
Yes of course.. even comes with some grated cheese on top.. ;)

snb
03-24-2015, 01:30 AM
Lasagne al forno:


Sub M_snb()
sn = ListObjects(1).DataBodyRange

With CreateObject("scripting.dictionary")
For j = 1 To UBound(sn)
.Item(sn(j, 1)) = .Item(sn(j, 1)) & vbLf & sn(j, 2)
Next

ListObjects(1).DataBodyRange.clearcontents
Cells(2, 1).Resize(.Count) = Application.Transpose(.keys)
Cells(2, 2).Resize(.Count) = Application.Transpose(.items)
End With
End Sub
or

Sub M_snb()
sn = Filter([transpose(A2:A9&char(10)&B2:B9)], "")
ListObjects(1).DataBodyRange.ClearContents

Do
c00 = Split(sn(0), vbLf)(0)
c01 = c01 & "_" & c00 & "|" & Replace(Join(Filter(sn, c00), ""), c00, "")
sn = Filter(sn, c00, False)
Loop Until UBound(sn) = -1

sn = Split(Mid(c01, 2), "_")
For j = 0 To UBound(sn)
Cells(2 + j, 1).Resize(, 2) = Split(sn(j), "|" & vbLf)
Next
End Sub