VBA to Create Data rows for Multi-Valued Columns

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

Hi Slicemahn!

Code:

---

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

---

Quote:

---

Originally Posted by 大灰狼1976

Hi Slicemahn!

Code:

---

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.

ok!

Code:

---

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

---

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.

Code:

---

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

---

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

Slice

Thanks

大灰狼1976

http://www.vbaexpress.com/forum/imag...er-offline.png! This works nicely. You have saved me from a lot of manual work. Thanks again!