MS Excel 宏：根據單元格值插入 x 行

Question

我們有一個包含數百名員工及其各自角色的電子表格，如下所示：

我們需要重新格式化此電子表格，以便每個角色都是其自己的單獨行項目：

我們發現了一個 VBA 宏，它允許我們在角色列中找到“/”時插入一行，但它只插入一行，而不是基於該人擁有的角色數量。 插入的行也是空白的。

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

有沒有辦法添加到這個代碼片段中，以便我們可以正確格式化我們的電子表格？

Answer 1

您可以使用拆分將角色拆分為單獨的角色。 代碼的 rest 是樣板文件。

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

Unpivot 壯舉。 Split

• 調整常量部分中的值。

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