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 (http://www.vbaexpress.com/forum/member.php?70849-大灰狼1976)
http://www.vbaexpress.com/forum/images/statusicon/user-offline.png! This works nicely. You have saved me from a lot of manual work. Thanks again!