MS Excel Macro: inserting x rows based on cell value - excel

Question

We have a spreadsheet of hundreds of Employees and their respective roles that looks like this:
We need to reformat this spreadsheet so that each role is its own separate line item:
We found a VBA Macro that allows us to insert a row if "/" is found in our Roles column, but it only inserts one row instead of based on the number of roles that person has. The rows inserted are also blank.
Sub Insertrowbelow()
'updateby Extendoffice
Dim i As Long
Dim xLast As Long
Dim xRng As Range
Dim xTxt As String
On Error Resume Next
xTxt = Application.ActiveWindow.RangeSelection.Address
Set xRng = Application.InputBox("please select the column with specific text:", "Kutools for Excel", xTxt, , , , , 8)
If xRng Is Nothing Then Exit Sub
If (xRng.Columns.Count > 1) Then
MsgBox "the selected range must be one column", , "Kutools for Excel"
Exit Sub
End If
xLast = xRng.Rows.Count
For i = xLast To 1 Step -1
If InStr(1, xRng.Cells(i, 1).Value, "/") > 0 Then
Rows(xRng.Cells(i + 1, 1).Row).Insert shift:=xlDown
End If
Next
End Sub
Is there a way to add on to this code snippet so that we can get our spreadsheet formatted correctly?

Answer 1

You can use Split to split the roles into separate roles. The rest of the code is boilerplate.
SourceRow = 1
DestinationRow = 1
For SourceRow = 1 To LastSourceRow
Employee = SourceWorksheet.Cells(SourceRow, 1).Value
Roles = Split(SourceWorksheet.Cells(SourceRow, 2).Value, "/")
For i = LBound(Roles) To UBound(Roles)
DestinationWorksheet.Cells(DestinationRow, 1).Value = Employee
DestinationWorksheet.Cells(DestinationRow, 2).Value = Roles(i)
DestinationRow = DestinationRow + 1
Next i
Next SourceRow

Answer 2

Split Column
Adjust the values in the constants section.
Option Explicit
Sub unPivot()
Const wsName As String = "Sheet1"
Const HeaderRow As Long = 1
Const Header As String = "Employee"
Const Delimiter As String = " / "
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sCell As Range
With wb.Worksheets(wsName).Rows(HeaderRow)
Set sCell = .Find(Header, .Cells(.Cells.Count), xlFormulas, xlWhole)
End With
If sCell Is Nothing Then
MsgBox "The header '" & Header & "' was not found.", _
vbCritical, "Missing Header"
Exit Sub
End If
Dim dcell As Range: Set dcell = sCell.Offset(1)
Dim srg As Range
With dcell
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then
MsgBox "No data found.", vbCritical, "No Data"
Exit Sub
End If
Set srg = .Resize(lCell.Row - .Row + 1, 2)
End With
Dim Data As Variant: Data = srg.Value
Dim srCount As Long: srCount = UBound(Data, 1)
ReDim Preserve Data(1 To srCount, 1 To 3)
Dim drCount As Long
Dim r As Long
For r = 1 To srCount
Data(r, 2) = Split(Data(r, 2), Delimiter)
Data(r, 3) = UBound(Data(r, 2))
drCount = drCount + Data(r, 3) + 1
Next r
Dim Result As Variant: ReDim Result(1 To drCount, 1 To 2)
Dim n As Long
Dim k As Long
For r = 1 To srCount
For n = 0 To Data(r, 3)
k = k + 1
Result(k, 1) = Data(r, 1)
Result(k, 2) = Data(r, 2)(n)
Next n
Next r
With dcell.Resize(, 2)
.Resize(k).Value = Result
'.Resize(.Worksheet.Rows.Count - .Row - k + 1).Offset(k).ClearContents
End With
End Sub