Transpose a text string while copying adjacent column data to new

[willc]

Folks,

I have a multi-column excel spreadsheet where one column has a text string
that I need to explode into individual rows while keeping the adjacent column
data. I doubt I'm using the correct nomenclature so I'm putting an example
of what I'm attempting below.

Thanks for any help on this.

A B C A
B c
store a typea a,b,c,d what I want is: store a typea a
store b typeb e,f,g,h store a typea
b
store a
typea c
store a
typea d
store b
typeb e
etc . . .

 

[JLatham]

Do you want to do this with worksheet functions or with VBA code (a macro)?
If we set it up using formulas and worksheet functions, then you'd have to
either retain the original row or come back behind things and do a copy /
paste special to convert copied values into absolutes so that you could
delete the original row of information. You've also got a lot of inserting
of rows and copying of formulas to do - depending on how far down the
worksheet your data goes, that could get rather tedious.

 

[willc]

Thanks for the reply . . . and VBA would be great. The more automated the
better. There will be several hundred rows. Thanks again for the help.

 

[JLatham]

If things are laid out as you've shown, this will work for you. There are
some Const definitions at the beginning of the code, just change those to
coincide with how things are really laid out on the sheet and it will work.
If you have more columns to copy on down the sheet, you can get an idea of
how to add constants and variables to deal with those from this code, or
contact me at [remove spaces] HelpFrom @ jlathamsite.com

One limit is that there can't be any empty cells in the primary column,
which I set up as A in this code:

Sub ExtendAndTranspose()
Const theWorksheet = "Sheet1" ' change as needed
Const firstColToCopy = "A" ' change as needed
Const secondColToCopy = "B" ' change as needed
Const columnToTranspose = "C" ' change as needed
Const firstRowWithData = 2 ' change as needed

Dim storeName As String
Dim storeType As String
Dim oneGroup As String ' to be transposed
Dim rOffset As Long ' pointer
Dim cOffset As Integer ' to transpose column
Dim rowToDelete As Long
Dim TLC As Integer ' transpose loop counter

'this assumes all rows used until no data;
' that is, no blank entries in column A until
' we are out of entries to work with
'
'make sure we are where we should be
Worksheets(theWorksheet).Select
'this is the "primary" column: A in this case
Range(firstColToCopy & firstRowWithData).Select
'calculate offset from base column (A) to the
'column with data to transpose (C)
cOffset = Range(columnToTranspose & "1").Column - _
Range(firstColToCopy & "1").Column
'turn of screen updating to improve performance
Application.ScreenUpdating = False
'begin the work
Do While Not IsEmpty(ActiveCell.Offset(rOffset, 0))
oneGroup = Trim(ActiveCell.Offset(rOffset, cOffset))
If Len(oneGroup) > 0 Then
'have some stuff to transpose
'get store name and type to fill on down
'as rows are inserted
rowToDelete = firstRowWithData + rOffset
storeName = Range(firstColToCopy & firstRowWithData). _
Offset(rOffset, 0)
storeType = Range(secondColToCopy & firstRowWithData). _
Offset(rOffset, 0)
For TLC = 1 To Len(oneGroup)
'only adds new row when there is a letter
'in "oneGroup" - skips commas, spaces, etc.
If UCase(Mid(oneGroup, TLC, 1)) >= "A" And _
UCase(Mid(oneGroup, TLC, 1)) <= "Z" Then
rOffset = rOffset + 1
ActiveCell.Offset(rOffset, 0).EntireRow.Insert
Range(firstColToCopy & firstRowWithData). _
Offset(rOffset, 0) = storeName
Range(secondColToCopy & firstRowWithData). _
Offset(rOffset, 0) = storeType
ActiveCell.Offset(rOffset, cOffset) = _
Mid(oneGroup, TLC, 1)
End If
Next ' TLC
Range(firstColToCopy & rowToDelete).EntireRow.Delete
rOffset = rOffset - 1 'adjust for deleted row
End If ' test of oneGroup length
rOffset = rOffset + 1 ' to next possible row
Loop ' empty cell test loop
Application.ScreenUpdating = True ' back on now
End Sub

 

[JLatham]

Forgot to mention/caution: try this out on a copy of your workbook or
worksheet in case I messed something up. Either it works and you can then
use the copy to overwrite the original, or it doesn't work and you can yell
at me, but you'll still have your original data in one piece.

 

[willc]

Awesome . . . thanks for all the help!

If things are laid out as you've shown, this will work for you. There are
some Const definitions at the beginning of the code, just change those to
coincide with how things are really laid out on the sheet and it will work.
If you have more columns to copy on down the sheet, you can get an idea of
how to add constants and variables to deal with those from this code, or
contact me at [remove spaces] HelpFrom @ jlathamsite.com

One limit is that there can't be any empty cells in the primary column,
which I set up as A in this code:

Sub ExtendAndTranspose()
Const theWorksheet = "Sheet1" ' change as needed
Const firstColToCopy = "A" ' change as needed
Const secondColToCopy = "B" ' change as needed
Const columnToTranspose = "C" ' change as needed
Const firstRowWithData = 2 ' change as needed

Dim storeName As String
Dim storeType As String
Dim oneGroup As String ' to be transposed
Dim rOffset As Long ' pointer
Dim cOffset As Integer ' to transpose column
Dim rowToDelete As Long
Dim TLC As Integer ' transpose loop counter

'this assumes all rows used until no data;
' that is, no blank entries in column A until
' we are out of entries to work with
'
'make sure we are where we should be
Worksheets(theWorksheet).Select
'this is the "primary" column: A in this case
Range(firstColToCopy & firstRowWithData).Select
'calculate offset from base column (A) to the
'column with data to transpose (C)
cOffset = Range(columnToTranspose & "1").Column - _
Range(firstColToCopy & "1").Column
'turn of screen updating to improve performance
Application.ScreenUpdating = False
'begin the work
Do While Not IsEmpty(ActiveCell.Offset(rOffset, 0))
oneGroup = Trim(ActiveCell.Offset(rOffset, cOffset))
If Len(oneGroup) > 0 Then
'have some stuff to transpose
'get store name and type to fill on down
'as rows are inserted
rowToDelete = firstRowWithData + rOffset
storeName = Range(firstColToCopy & firstRowWithData). _
Offset(rOffset, 0)
storeType = Range(secondColToCopy & firstRowWithData). _
Offset(rOffset, 0)
For TLC = 1 To Len(oneGroup)
'only adds new row when there is a letter
'in "oneGroup" - skips commas, spaces, etc.
If UCase(Mid(oneGroup, TLC, 1)) >= "A" And _
UCase(Mid(oneGroup, TLC, 1)) <= "Z" Then
rOffset = rOffset + 1
ActiveCell.Offset(rOffset, 0).EntireRow.Insert
Range(firstColToCopy & firstRowWithData). _
Offset(rOffset, 0) = storeName
Range(secondColToCopy & firstRowWithData). _
Offset(rOffset, 0) = storeType
ActiveCell.Offset(rOffset, cOffset) = _
Mid(oneGroup, TLC, 1)
End If
Next ' TLC
Range(firstColToCopy & rowToDelete).EntireRow.Delete
rOffset = rOffset - 1 'adjust for deleted row
End If ' test of oneGroup length
rOffset = rOffset + 1 ' to next possible row
Loop ' empty cell test loop
Application.ScreenUpdating = True ' back on now
End Sub

Thanks for the reply . . . and VBA would be great. The more automated the
better. There will be several hundred rows. Thanks again for the help.