*** NOTE - Revised code posted August 12, 2013 in response ***
*** to a problem Marcelo Branco pointed out in Message #19 ***
The following scenario seems to come up somewhat often at the various forums I participate in... take a table of data where one column contains delimited data and split that delimited data so that each item is on a row of its own, copying the associated data into the blank cells created by the split. Visually, we want to go from this table...
A B C D 1 Name Client
NumberParts
Ordered2 Rick 1111111 P1, P2, P3 3 Sam 2222222 P2, P5 4 Joe 3333333 P3 5 Bill 4444444 P4, P6, P7, P8 6
to this one
A B C D 1 Name Client
NumberParts
Ordered2 Rick 1111111 P1 3 Rick 1111111 P2 4 Rick 1111111 P3 5 Sam 2222222 P2 6 Sam 2222222 P5 7 Joe 3333333 P3 8 Bill 4444444 P4 9 Bill 4444444 P6 10 Bill 4444444 P7 11 Bill 4444444 P8 12
Below is a macro that will accomplish this task. Note though that I have generalize it somewhat. Usually in the requests the delimited data is in the last column as shown above, however, there is no need for this to be the case... this macro will allow any column to be the delimited column.
There are four constants (the Const statements) that you need to match to your actual worksheet conditions in order to work. The first is named Delimiter and it can be one or more characters long. The second is named DelimitedColumn and specifies the column letter containing the delimited cells. The third is named TableColumns and it specifies the columns occupied by your data (which must always include the column with the delimited cells. The last one is named StartRow and it specifies the row containing the first piece of data (that is, it is the row number below the headers, if any).Code:Sub RedistributeData() Dim X As Long, LastRow As Long, A As Range, Table As Range, Data() As String Const Delimiter As String = ", " Const DelimitedColumn As String = "C" Const TableColumns As String = "A:C" Const StartRow As Long = 2 Application.ScreenUpdating = False LastRow = Columns(TableColumns).Find(What:="*", SearchOrder:=xlRows, _ SearchDirection:=xlPrevious, LookIn:=xlFormulas).Row For X = LastRow To StartRow Step -1 Data = Split(Cells(X, DelimitedColumn), Delimiter) If UBound(Data) > 0 Then Intersect(Rows(X + 1), Columns(TableColumns)).Resize(UBound(Data)).Insert xlShiftDown End If If Len(Cells(X, DelimitedColumn)) Then Cells(X, DelimitedColumn).Resize(UBound(Data) + 1) = WorksheetFunction.Transpose(Data) End If Next LastRow = Cells(Rows.Count, DelimitedColumn).End(xlUp).Row On Error Resume Next Set Table = Intersect(Columns(TableColumns), Rows(StartRow).Resize(LastRow - StartRow + 1)) If Err.Number = 0 Then Table.SpecialCells(xlBlanks).FormulaR1C1 = "=R[-1]C" Columns(DelimitedColumn).SpecialCells(xlFormulas).Clear Table.Value = Table.Value End If On Error GoTo 0 Application.ScreenUpdating = True End Sub
Bookmarks