Text to columns i smaking new columns for each person, i need new rows for each personTake a look at the Text To Columns feature on the ribbon?
Text to columns is making new columns for each person, i need new rows for each person.
Book1 | ||||
---|---|---|---|---|
A | B | |||
1 | Target | Sarah,John,Steven | ||
2 | Walmart | Mike,Kyle,Kevin | ||
3 | ||||
4 | Target | Sarah | ||
5 | Target | John | ||
6 | Target | Steven | ||
7 | Walmart | Mike | ||
8 | Walmart | Kyle | ||
9 | Walmart | Kevin | ||
Sheet1 |
Private Sub ArrayTestII()
Dim ws As Worksheet
Dim rngA As Range
Dim i, j, lRow&
Dim arrA As Variant
Dim collA As Object
Dim strA() As String
Set ws = Sheets("Sheet1")
lRow = ws.Range("A1").End(xlDown).Row
arrA = ws.Range("A1:B" & lRow).Value2
Set collA = CreateObject("System.Collections.ArrayList")
For i = 1 To UBound(arrA)
strA = Split(arrA(i, 2), ",")
For j = 0 To UBound(strA)
collA.Add Join(Array(arrA(i, 1), strA(j)), ";")
Next j
Next i
Set rngA = ws.[A4].Resize(collA.Count)
With rngA
.Value = Application.Transpose(collA.toArray)
.TextToColumns DataType:=xlDelimited, Semicolon:=True
End With
End Sub