VBA將Excel單元格中的多行文本拆分為單獨的行，並保持相鄰的單元格值

Question

運行宏后，請查看顯示我的數據和預期數據的附件圖像，

• 我想在B列中拆分多行單元格，並在單獨的行中列出，並從第一個空格中刪除文本。 此值將稱為SESE_ID，並且對於同一行中的每個SESE_ID，都應具有C列中的RULE。
• 如果A列中有多個以逗號或空格分隔的前綴，請對每個前綴重復上述值。

請有人在宏中幫助我...

1. 所附的第一張圖片是樣本來源：

2. 以下是宏：

Sub Complete_sepy_load_macro()
    Dim ws, s1, s2 As Worksheet
    Dim rw, rw2, rw3, col1, count1, w, x, y, z, cw As Integer
    Dim text1 As String
    Dim xwalk As String
    Dim TOSes As Variant

    Application.DisplayAlerts = False
    For Each ws In Sheets
        If ws.Name = "CMC_SEPY_SE_PYMT" Then Sheets("CMC_SEPY_SE_PYMT").Delete
    Next
    Application.DisplayAlerts = True

    Set s2 = ActiveSheet
    g = s2.Name
    Sheets.Add.Name = "CMC_SEPY_SE_PYMT"

    Set s1 = Sheets("CMC_SEPY_SE_PYMT")

    s1.Cells(1, 1) = "SEPY_PFX"
    s1.Cells(1, 2) = "SEPY_EFF_DT"
    s1.Cells(1, 3) = "SESE_ID"
    s1.Cells(1, 4) = "SEPY_TERM_DT"
    s1.Cells(1, 5) = "SESE_RULE"
    s1.Cells(1, 6) = "SEPY_EXP_CAT"
    s1.Cells(1, 7) = "SEPY_ACCT_CAT"
    s1.Cells(1, 8) = "SEPY_OPTS"
    s1.Cells(1, 9) = "SESE_RULE_ALT"
    s1.Cells(1, 10) = "SESE_RULE_ALT_COND"
    s1.Cells(1, 11) = "SEPY_LOCK_TOKEN"
    s1.Cells(1, 12) = "ATXR_SOURCE_ID"
    s1.Range("A:A").NumberFormat = "@"
    s1.Range("B:B").NumberFormat = "m/d/yyyy"
    s1.Range("C:C").NumberFormat = "@"
    s1.Range("D:D").NumberFormat = "m/d/yyyy"
    s1.Range("E:E").NumberFormat = "@"
    s1.Range("F:F").NumberFormat = "@"
    s1.Range("G:G").NumberFormat = "@"
    s1.Range("H:H").NumberFormat = "@"
    s1.Range("I:I").NumberFormat = "@"
    s1.Range("J:J").NumberFormat = "@"
    s1.Range("K:K").NumberFormat = "0"
    s1.Range("L:L").NumberFormat = "m/d/yyyy"


    rw2 = 2

    x = 1
    y = 1
    z = 1
    'service id column
    Do
        y = y + 1
    Loop Until s2.Cells(1, y) = "Service ID"

    'Rule column
    Do
        w = w + 1
    Loop Until Left(s2.Cells(1, w), 4) = "Rule"

    'Crosswalk column
    Do
        cw = cw + 1
    Loop Until Left(s2.Cells(1, cw).Value, 9) = "Crosswalk"

    'Alt rule column (location derived from rule column)
    'counts # of cells between "rule" and "alt rule", used as precedent for rest of "alt rule" cells
    ar = w
    Do
        ar = ar + 1
    Loop Until Left(s2.Cells(1, ar).Value, 3) = "Alt"
    ar = ar - w

    'prefix row
    Do
        x = x + 1
    Loop Until s2.Cells(x, w)  ""

    'first service id row
    Do
        z = z + 1
    Loop Until s2.Cells(z, y)  ""

            'change rw = z + 2 to rw = z, was skipping first two rows
            For rw = z To s2.Range("a65536").End(xlUp).Row
                If s2.Cells(rw, y)  "" Then

                    If InStr(1, s2.Cells(rw, y), Chr(10))  0 Then
                        TOSes = Split(s2.Cells(rw, y).Value, Chr(10)) 'Chr(10) is the "new line" character
                        count1 = 0
                        Do
                            If Trim(TOSes(count1))  "" Then
                                For col1 = w To s2.UsedRange.Columns.Count
                                    If Left(s2.Cells(1, col1), 4) = "Rule" Then
                                        If InStr(1, TOSes(count1), " ") > 0 Then
                                            s1.Cells(rw2, 3) = Trim(Left(TOSes(count1), InStr(1, TOSes(count1), " ")))  'sese
                                        Else
                                            s1.Cells(rw2, 3) = TOSes(count1)
                                        End If

                                        s1.Cells(rw2, 1) = s2.Cells(x, col1) 'prefix
                                        s1.Cells(rw2, 5) = s2.Cells(rw, col1) 'rule
                                        'use crosswalk service id to populate alt rule
                                        If s2.Cells(rw, cw).Value  "" Then
                                            If xwalk = "" Then
                                                Match = False
                                                xwalk = Trim(s2.Cells(rw, cw)) & " "
                                                rwcw = z
                                                Do
                                                    If InStr(1, s2.Cells(rwcw, y).Value, xwalk, vbTextCompare) > 0 Then
                                                        'obtain rule and write to alt rule column of current row
                                                        s2.Cells(rw, col1).Offset(0, ar).Value = s2.Cells(rwcw, w).Value
                                                        Match = True
                                                    End If
                                                    rwcw = rwcw + 1
                                                Loop Until Match = True
                                            End If
                                        End If
                                        s1.Cells(rw2, 9) = s2.Cells(rw, col1).Offset(0, ar) 'alt rule
                                        s1.Cells(rw2, 7) = "TBD" 'cac
                                        s1.Cells(rw2, 13) = s2.Name 'file

                                         rw2 = rw2 + 1
                                    End If
                                    xwalk = ""
                                Next col1
                            End If
                            count1 = count1 + 1
                        Loop Until count1 = UBound(TOSes) + 1
                    Else
                        For col1 = w To s2.UsedRange.Columns.Count
                            If Left(s2.Cells(1, col1), 4) = "Rule" Then
                                If InStr(1, s2.Cells(rw, y), " ") > 0 Then
                                    s1.Cells(rw2, 3) = Trim(Left(s2.Cells(rw, y), 4))  'sese
                                Else
                                    s1.Cells(rw2, 3) = s2.Cells(rw, y)
                                End If

                                s1.Cells(rw2, 1) = s2.Cells(x, col1) 'prefix
                                s1.Cells(rw2, 5) = s2.Cells(rw, col1) 'rule
                                s1.Cells(rw2, 9) = s2.Cells(rw, col1).Offset(0, ar) 'alt rule
                                s1.Cells(rw2, 7) = "TBD" 'cac
                                s1.Cells(rw2, 13) = s2.Name 'file

                                rw2 = rw2 + 1
                            End If
                        Next col1
                    End If
                ElseIf s2.Cells(rw, y) = "" And Trim(s2.Cells(rw, w))  "" Then
                    If Len(s2.Cells(rw, 1)) >= 10 Then
                        text1 = Left(s2.Cells(rw, 1), 10) & " |row: " & rw 'sese
                    Else
                        text1 = s2.Cells(rw, 1) & " row: " & rw 'sese
                    End If
                        For col1 = w To s2.UsedRange.Columns.Count
                            If Left(s2.Cells(1, col1), 4) = "Rule" Then
                                s1.Cells(rw2, 3) = text1 'sese
                                s1.Cells(rw2, 3).Interior.ColorIndex = 6
                                s1.Cells(rw2, 1) = s2.Cells(x, col1) 'prefix
                                s1.Cells(rw2, 5) = s2.Cells(rw, col1) 'rule
                                s1.Cells(rw2, 9) = s2.Cells(rw, col1).Offset(0, ar) 'alt rule
                                s1.Cells(rw2, 7) = "TBD" 'cac
                                s1.Cells(rw2, 13) = s2.Name 'file

                                rw2 = rw2 + 1
                            End If
                        Next col1
                End If
            Next


        For rw3 = 2 To s1.UsedRange.Rows.Count
            s1.Cells(rw3, 2) = "1/1/2009"
            s1.Cells(rw3, 4) = "12/31/9999"
            s1.Cells(rw3, 11) = 1
            s1.Cells(rw3, 12) = "1/1/1753"
        Next rw3
        Dim wb As Workbook
        Dim wss, wsSepy, wsSID As Worksheet 'SID = Serivce ID Spreadsheet
        Dim sepyRow, sepyCol, acctCol, sidSeseCol, sidAcctCol, j As Long
        Dim cell As Range
        Dim cellRange As Range
        Dim topRow As Range
        Dim sepySese As String

        MsgBox "All set, make sure there is no #N/A in SESE_RULE column"
        End Sub

3. 下圖是我得到的輸出：

4. 問題：如果您看到源數據，則在A列中有SEPY_PFX。我希望為每個SEPY重復每一行。 目前，我的代碼給了我RULE作為SEPY_PFX，但我仍在努力，但是如果有人能很快幫助我，這將是很高興的，它已經超出了我的腦海。

Answer 1

該代碼將在您發布的第一個示例上起作用，以提供所需的輸出：

原始資料：

原始結果：

它通過使用Class和Collections來工作 ，一次創建一個條目，然后將其放在一起得到結果。

我使用數組來收集和輸出數據，因為這樣可以更快地工作。 在您的原著中，您有一些字體着色，我已經繼承了。

您應該能夠使其適應實際數據，但是，如果不能，我建議您在某些文件共享網站（例如DropBox）上發布原始數據的“經過消毒處理”的副本，其中包含正確的列等。 OneDrive等； 並在此處發布鏈接，以便我們可以看到“真實內容”

關於類的使用，請訪問Chip Pearson的網站。

另外，請閱讀代碼中的注釋以獲取解釋和建議。

首先插入一個類模塊，將其重命名為cOfcCode並將以下代碼粘貼到其中：

'Will need to add properties for the additional columns

Option Explicit

Private pSEPY As String
Private pFontColor As Long
Private pSESE As String
Private pRule As String

Public Property Get SEPY() As String
    SEPY = pSEPY
End Property
Public Property Let SEPY(Value As String)
    pSEPY = Value
End Property

Public Property Get FontColor() As Long
    FontColor = pFontColor
End Property
Public Property Let FontColor(Value As Long)
    pFontColor = Value
End Property

Public Property Get Rule() As String
    Rule = pRule
End Property
Public Property Let Rule(Value As String)
    pRule = Value
End Property

Public Property Get SESE() As String
    SESE = pSESE
End Property
Public Property Let SESE(Value As String)
    pSESE = Value
End Property

然后，在常規模塊中：

Option Explicit
Sub ReformatData()
    Dim wsSrc As Worksheet, wsRes As Worksheet
    Dim rSrc As Range, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim vSEPY As Variant, vSESE As Variant
    Dim cOC As cOfcCode
    Dim colOC As Collection
    Dim lRGB As Long
    Dim I As Long, J As Long, K As Long

'Change Sheet references as needed
Set wsSrc = Worksheets("Sheet2")
Set wsRes = Worksheets("Sheet3")

'Assuming Data is in Columns A:C
With wsSrc
    Set rSrc = .Range("A1", .Cells(.Rows.Count, "C").End(xlUp))
End With
Set rRes = wsRes.Range("A1")

vSrc = rSrc
Set colOC = New Collection  'Collection of each "to be" row
For I = 2 To UBound(vSrc, 1)

    'Split SEPY_PFX into relevant parts
    vSEPY = Split(vSrc(I, 1), ",")
    For J = 0 To UBound(vSEPY)

        'Get the font color from the original cell
        With rSrc(I, 1)
            lRGB = .Characters(InStr(1, .Value, vSEPY(J), vbTextCompare), 1).Font.Color
        End With

        'Split SESE_ID into relevant parts
        vSESE = Split(vSrc(I, 2), vbLf)

        'Iterate through each SESE_ID, picking up the SEPY_PFX, and RULE
        For K = 0 To UBound(vSESE)
            Set cOC = New cOfcCode

            'Will need to adjust for the extra columns
            With cOC
                .FontColor = lRGB
                .Rule = vSrc(I, 3)
                .SEPY = vSEPY(J)
                .SESE = vSESE(K)
                colOC.Add cOC '<-- ADD to the collection
            End With
        Next K
    Next J
Next I

'Put together the Results
ReDim vRes(0 To colOC.Count, 1 To UBound(vSrc, 2))

'Copy the column headings from the source
For I = 1 To UBound(vRes, 2)
    vRes(0, I) = vSrc(1, I)
Next I

'Will need to add entries for the other columns
For I = 1 To colOC.Count
    With colOC(I)
        vRes(I, 1) = .SEPY
        vRes(I, 2) = .SESE
        vRes(I, 3) = .Rule
    End With
Next I

'Clear the results worksheet and write the results
wsRes.Cells.Clear
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
rRes = vRes

'Add the correct font color and format
For I = 1 To colOC.Count
    rRes.Rows(I + 1).Font.Color = colOC(I).FontColor
Next I

With rRes.Rows(1)
    .Font.Bold = True
    .HorizontalAlignment = xlCenter
End With

rRes.EntireColumn.AutoFit

End Sub

對代碼中的工作表引用進行更改（只需要在常規模塊的開頭進行更改即可。

首先在您的原始示例上嘗試一下，這樣您就可以了解其工作原理，然后將更多的列添加到Class和Collection中，或者在此處發布更多詳細信息

Answer 2

我假定原始數據在工作表“ DATA”中，並且已經存在用於存儲已處理數據的工作表“ Expected Output”。

您的代碼將為：大多數行的操作均通過注釋（“'”的右側）進行解釋。

Sub processData()
Dim oWS As Worksheet, pWS As Worksheet
Dim oRow As Long, pRow As Long
Dim splitMultiLine As String, splitPerfix As String
Dim c As Long, i As Long, j As Long, k As Long
Dim prefixes As Variant, lines As Variant
Dim dataACol As String, dataBCol As String, dataCCol As String


Set oWS = Worksheets("DATA") 'original data
Set pWS = Worksheets("Expected Output") 'processed data

'Copy title row
For c = 1 To 3
  pWS.Cells(1, c) = oWS.Cells(1, c)
Next c

oRow = 2 ' row of oWS
pRow = 2 ' row of pWS

With oWS
  While (.Cells(oRow, 1) <> "") 'Loop while A colmn has value
    dataACol = .Cells(oRow, 1) 'data in A column
    dataBCol = .Cells(oRow, 2) 'data in B column
    dataCCol = .Cells(oRow, 3) 'data in C colum

    prefixes = Split(dataACol, ",") ' split prefixes by comma
    lines = Split(dataBCol, Chr(10)) ' split multi lines in a cell by newline (Char(10))

    For i = LBound(prefixes) To UBound(prefixes)
      For j = LBound(lines) To UBound(lines)
        pWS.Cells(pRow, 1) = Trim(prefixes(i)) ' A column of output
        k = InStr(lines(j), " ")
        pWS.Cells(pRow, 2) = Left(lines(j), k - 1) ' B column of output
        pWS.Cells(pRow, 3) = dataCCol ' C column of output
        pRow = pRow + 1
      Next j
    Next i
    oRow = oRow + 1
  Wend
End With
End Sub