Sub x()
Dim c As Long, vOut(), vIn(), i As Long, j As Long, n As Long
Application.DisplayAlerts = False
Application.ScreenUpdating = False
With Sheets("Before")
c = .Range("A1").CurrentRegion.Columns.Count
.Range("A1").Resize(, c).Copy Sheets("After").Range("A1")
With .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Offset(, c)
.Formula = "=A2&T2"
.Value = .Value
End With
vIn = .Range("A1").CurrentRegion.Value
.Columns(c + 1).Clear
End With
ReDim vOut(1 To UBound(vIn, 1))
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(vIn, 1)
If Not .Exists(vIn(i, c + 1)) Then
n = n + 1
For j = 1 To c
vOut(n) = vOut(n) & "#" & vIn(i, j)
Next j
If Left(vOut(n), 1) = "#" Then vOut(n) = Mid(vOut(n), 2)
.Add vIn(i, c + 1), n
ElseIf .Exists(vIn(i, c + 1)) Then
For j = 1 To c
vOut(.Item(vIn(i, c + 1))) = vOut(.Item(vIn(i, c + 1))) & "#" & vIn(i, j)
Next j
If Left(vOut(.Item(vIn(i, c + 1))), 1) = "#" Then
vOut(.Item(vIn(i, c + 1))) = Mid(vOut(.Item(vIn(i, c + 1))), 2)
End If
End If
Next i
End With
For j = 1 To n
Sheets("After").Range("A1").Offset(j) = vOut(j)
Next j
Sheets("After").Range("A2").Resize(n).TextToColumns DataType:=xlDelimited, _
ConsecutiveDelimiter:=True, _
Other:=True, OtherChar:="#"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Sheets("After").Range("A2").Resize(n).TextToColumns DataType:=xlDelimited, _
ConsecutiveDelimiter:=False, _
Other:=True, OtherChar:="#"
Title | # Comments | Views | Activity |
---|---|---|---|
Filter and delete | 6 | 14 | |
How to Auto-fill data in Database | 2 | 19 | |
Excel Autofill Dropdown List with Combobox : How to make use of Tab and Enter key to input a value. | 5 | 18 | |
Changing absolute cell references | 3 | 16 |
Join the community of 500,000 technology professionals and ask your questions.
Connect with top rated Experts
16 Experts available now in Live!