Unique scenario- automate, make parts of text in cell into own row.


Scenario: Column A contains a unique project number. Column B has associated company names listed, separated by commas.
I need to have an individual row per each company name. So column A will be the project number. Column B will be one company name. The next row could contain the same project number in A (if multiple companies were on that project) but the second company listed in B.

Some projects had only one company working    Others had up to 30.

How do I make this format change without manually doing it. (25,000 lines approx)

I know how to separate column B into multiple columns separating by comma. But then what? I need them all stacked in rows. Not columns.


Thank you!




Below is the code that will do the job you describe. Install it in a standard code module of your project. That's one which you have to insert, whose default name will be Module1. None of the existing modules is suitable but you can simply drag the TeachExcel module from the attached workbook into your project in the VB Editor's Project Explorer window while both workbooks are open.

Option Explicit

Private Enum Nws                    ' worksheet navigation
    ' Variatus @TeachExcel
    ' 09 Jan 2019
    NwsFirstDataRow = 2
    NwsProject = 1                  ' column with project ID (1 = A)
    NwsCompany                      ' undefined means previous + 1, here it's 2 = B
End Enum

Sub SplitProjectsToRows()
    ' Variatus @TeachExcel
    ' 09 Jan 2019

    Dim Ws As Worksheet
    Dim Sp() As String              ' company names
    Dim i As Integer                ' index to company names
    Dim R As Long                   ' sheet row numbers

    ' identify the tab to work on:-
    ' either name the tab as "Projects" or change the name here
    ' NOTE: The workbook is the active one (the one you last saw)
    '       which need not necessarily be ThisWorkbook
    Set Ws = ActiveWorkbook.Worksheets("Projects")

    ' screen will not change until all the work is done
    Application.ScreenUpdating = False
    With Ws
        ' determine the last used row in the Project column
        ' then work from the bottom up because row numbers will
        ' change when new rows are inserted. But working from the
        ' end leaves original row numbers unchanged.
        For R = .Cells(.Rows.Count, NwsProject).End(xlUp).Row To NwsFirstDataRow Step -1
            Sp = Split(.Cells(R, NwsCompany).Value, ",")
            If UBound(Sp) > 0 Then
                For i = 1 To UBound(Sp)
                    .Rows(R + 1).Insert Shift:=xlDown
                Next i
                Application.CutCopyMode = False
                For i = 0 To UBound(Sp)
                    .Cells(R + i, NwsCompany).Value = Trim(Sp(i))
                Next i
            End If

            ' progress report in the StatusBar (left bottom of screen)
            ' updates every 25 rows
            If R Mod 25 = 0 Then
                Application.StatusBar = R & " rows to go"
            End If
        Next R
    End With

    With Application
        .ScreenUpdating = True
        .StatusBar = "Done"
    End With
End Sub

Please read my comments in the code. They will help you. Note that you can modify the enumeration at the top of the code to specify another first row or other columns for Project ID and Company Name. The column captions are immaterial, and the program will copy all data in each row to all inserted rows.

Note that the company names must be comma delimited. The macro can be modified to use another delimiter. It deals with leading or trailing blank spaces.

Here's a little extra. You may not like to have the project ID repeated in each row. In the attached workbook I have changed the font colour of repetitions to red. If you change the colour to white (background colour) they will become invisible (but you can still see the project number if you click on the cell). This must be done after the code has run. And this is how to do it.

  1. Select the Project column (all 25,000 rows)
    1. On the Home tab click Find & Select > GoTo ...
    2. In the Reference field enter the address of the range you wish to select, e.g. A2:A25000
    3. Press OK.
  2. Without changing the selection, select Conditional formatting on the Home tab.
  3. Select New Rule and Use a formula to determine which cells to format.
  4. Format values where this formula is true 

    where A2 is the cell containing the first project number and A1 is the cell immediately above it.
  5. Set the Format to the font colour of your sheet's background.

The Project tab shows the result after running the code and applying CF. To repeat, copy the Original to the Project sheet and run the code again, the apply CF as described above.


Answer the Question

You must create an account to use the forum. Create an Account or Login