Reformat data from rows to columns

  • Thread starter Thread starter autoguy
  • Start date Start date
A

autoguy

In column A, I have a unique value. In column B, I have a series of
additional values which are keyed to match the unique value in column
A. Here is an example of what I have:

COLUMN A COLUMN B
RDK3173BK 14542 , 14567 , 16763
WSK3173AK 14644 , 16688 , 16789 , 16821
PCK3MOP 14638 , 16637 , 16815 , 14639 , 16638 , 16816

I need to convert the series of values in Column B to individual rows
that still match Column A. Like this:

COLUMN A COLUMN B
RDK3173BK 14542
RDK3173BK 14567
RDK3173BK 16763
WSK3173AK 14644
WSK3173AK 16688
WSK3173AK 16789
WSK3173AK 16821
PCK3MOP 14638
PCK3MOP 16637
PCK3MOP 16815
PCK3MOP 14639
PCK3MOP 16638
PCK3MOP 16816
 
Give this macro a try. It's non destructive as long as you use separate
sheets for the source (where your current data is) and destination (where we
will put the revised data) sheets are different. Set those names up in the
code below. It works with the sample data provided. Odd situations such as
having just a "," for an entry in column B or ending an entry in column B
with a "," could blow it up.

Sub TransposeInGroups()
'destination sheet cannot be same as source sheet
'as currently written.
Const destSheetName = "Sheet2" ' change as needed

Const sourceSheetName = "Sheet1" ' change as needed
Const firstSourceRow = 2 ' change if needed
Const groupSeparator = ","
Dim sepPosition As Integer
Dim sourceListRange As Range
Dim anySourceListEntry As Range
Dim colBSource As String
Dim anyNumber As String

Dim destSheet As Worksheet

Set destSheet = Worksheets(destSheetName)
Set sourceListRange = Worksheets(sourceSheetName). _
Range("A" & firstSourceRow & ":" & _
Worksheets(sourceSheetName).Range("A" & Rows.Count). _
End(xlUp).Address)
'work through entries in column A
For Each anySourceListEntry In sourceListRange
colBSource = anySourceListEntry.Offset(0, 1).Text
Do While InStr(colBSource, groupSeparator) > 0
sepPosition = InStr(colBSource, groupSeparator)
anyNumber = Trim(Left(colBSource, _
sepPosition - 1))
destSheet.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = _
anySourceListEntry
destSheet.Range("A" & Rows.Count).End(xlUp).Offset(0, 1) = _
anyNumber
colBSource = Right(colBSource, Len(colBSource) - sepPosition)
Loop
'colBSource will still have last group in it
destSheet.Range("A" & Rows.Count).End(xlUp).Offset(1, 0) = _
anySourceListEntry
destSheet.Range("A" & Rows.Count).End(xlUp).Offset(0, 1) = _
Trim(colBSource)
Next
'some housekeeping
Set destSheet = Nothing
Set sourceListRange = Nothing
End Sub
 
You should be able to do what you want using Split Function.
code below not fully tested but should place results from your sample data
on new sheet - you can rename sheet references to suit but ensure destination
sheet exists before running.

Hope helpful

Sub SplitColBValues()
Dim ItemSplit As Variant
Dim intIndex As Integer
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws1rn As Long
Dim ws2rn As Long

'change sheet names as required
Set ws1 = Worksheets("Sheet1")

Set ws2 = Worksheets("Sheet2")

ws1rn = 1
ws2rn = 1

Do Until ws1.Range("A" & ws1rn).Value = ""


ItemSplit = Split(ws1.Range("B" & ws1rn).Value, ",")

For intIndex = LBound(ItemSplit) To UBound(ItemSplit)

With ws2

.Range("A" & ws2rn).Value = ws1.Range("A" & ws1rn).Value

.Range("B" & ws2rn).Value = ItemSplit(intIndex)

End With

ws2rn = ws2rn + 1

Next

ws1rn = ws1rn + 1

Loop

MsgBox "All Done!"

End Sub
 
Back
Top