VBA to Create Data rows for Multi-Valued Columns

[Slicemahn]

Hi VBAExpress Nation,

I have attached a small portion of a dataset that I am finding a challenge to automate with VBA. It is a list of courses taught by our instructors. We need to analyze their time in different categories by delivery of content is one. In some cases, more than one instructor may be delivering a course or be in attendance for their own training.

Is there a way to create single row of data for multi-valued columns? My spreadsheet captures the data (it is actually 5000 rows!) and the desired results.

Thank you in advance for your help.

Slice

[大灰狼1976]

Hi Slicemahn!

Private Sub test()
Dim i&, arr, s$
Application.ScreenUpdating = False
With Sheets("Expected Result")
  Sheets("Data").Cells.Copy .[a1]
  For i = .[a65536].End(3).Row To 2 Step -1
    s = Replace(.Cells(i, 4), ".", ";")
    arr = Split(s, "; ")
    If UBound(arr) > 0 Then
      .Rows(i).Copy
      .Rows(i + 1 & ":" & i + UBound(arr)).Insert Shift:=xlDown
      .Cells(i, 4).Resize(UBound(arr) + 1) = Application.Transpose(arr)
    End If
  Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

[Slicemahn]

Hi Slicemahn!

Private Sub test()
Dim i&, arr, s$
Application.ScreenUpdating = False
With Sheets("Expected Result")
  Sheets("Data").Cells.Copy .[a1]
  For i = .[a65536].End(3).Row To 2 Step -1
    s = Replace(.Cells(i, 4), ".", ";")
    arr = Split(s, "; ")
    If UBound(arr) > 0 Then
      .Rows(i).Copy
      .Rows(i + 1 & ":" & i + UBound(arr)).Insert Shift:=xlDown
      .Cells(i, 4).Resize(UBound(arr) + 1) = Application.Transpose(arr)
    End If
  Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Hi,
Thanks for this but it is not what I am looking for: The "Expected Result" was included to show everyone what the end result should be it should not be involved in the code. I need the "Data" worksheet to show each instructor's delivery of courses and attendance of training. These must be done individually. So if a course has two or more instructors then I need each instructor to be shown individually rather than be grouped in one field with other instructors.

IHTH, Slice.

[大灰狼1976]

ok!

Private Sub test()
Dim i&, arr, s$
Application.ScreenUpdating = False
With Sheets("Data")
  For i = .[a65536].End(3).Row To 2 Step -1
    s = Replace(.Cells(i, 4), ".", ";")
    arr = Split(s, "; ")
    If UBound(arr) > 0 Then
      .Rows(i).Copy
      .Rows(i + 1 & ":" & i + UBound(arr)).Insert Shift:=xlDown
      .Cells(i, 4).Resize(UBound(arr) + 1) = Application.Transpose(arr)
    End If
  Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

[Paul_Hossler]

1. Be advised that you had as 'period' after 'Sunil' in 'Smith, Canton; Fergus, Darryl; Chaudry, Sunil; Gatwick, Gerald; Pearson, George'

I changed it to a semicolon like the rest

2. I'd do something simple like this.

Option Explicit

Sub SplitData()
    Dim wsData As Worksheet, wsOutput As Worksheet
    Dim rData As Range
    Dim iOut As Long, iIn As Long, iSplit As Long
    Dim vData As Variant
    Set wsData = Worksheets("Data")
    Set wsOutput = Worksheets("Output")
    
    Set rData = wsData.Cells(1, 1).CurrentRegion
    wsData.Cells(1, 1).ClearContents
    iOut = 1
    
    Application.ScreenUpdating = False

    With rData
        For iIn = 1 To .Rows.Count
            vData = Split(.Cells(iIn, 4).Value, ";")
            
            For iSplit = LBound(vData) To UBound(vData)
                .Rows(iIn).Copy wsOutput.Cells(iOut, 1).Resize(1, .Columns.Count)
                wsOutput.Cells(iOut, 4).Value = vData(iSplit)
                iOut = iOut + 1
            Next iSplit
        Next iIn
    End With
    
    wsOutput.Cells(1, 1).CurrentRegion.EntireColumn.AutoFit
    Application.ScreenUpdating = True

End Sub

[Slicemahn]

Nice Paul! Yes you are correct: it should always be a semi-colon to separate the different instructors!

Slice

[Slicemahn]

Thanks

大灰狼1976

! This works nicely. You have saved me from a lot of manual work. Thanks again!