您的位置: 首页  >  技术问答  >  VBA将excel单元格中的多行文本分割成单独的行并保留相邻单元格值

VBA将excel单元格中的多行文本分割成单独的行并保留相邻单元格值

分类: 技术问答 • 2022-05-02 14:43:35
问题描述：

请参阅运行宏后显示我的数据和预期数据的附件，

Please see the attach image which shows my data and expected data after running the macro,


  • 我想拆分多行单元格列在B列中，并列在单独的行中，并从第一个空格中删除文本。该值将被称为SESE_ID，并且对于来自同一行的每个SESE_ID应该具有来自列C的RULE。

  • 如果列A中有多个前缀以逗号或空格分隔-comma，然后为每个前缀重复上述值。

请有人帮助我在宏...

Please someone help me in the macro...


  1. 附加的第一张图片是示例来源：


  1. 以下是宏： / li>
  1. And following is the macro:





    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




  1. 下图是我得到的输出：

  1. Below image is the output I got:

问题：如果您看到源数据，我在列A中有SEPY_PFX。我想要为每个SEPY重复每一行。目前我的代码给了我RULE作为SEPY_PFX，我仍然在工作，但如果有人快速帮助我，这将是很高兴，它已经在我的头上。

Problem: If you see the source data, I have SEPY_PFX in column A. I wanted every row to be repeated for each SEPY. Currently my code gave me RULE as SEPY_PFX, I am still working on it BUT it will be glad if someone help me on this quickly, it is already going above my head.


答

此代码将适用于您发布的第一个示例，以提供您想要的输出：

This code will work on the first example you posted to give the output you wanted:

原始来源：

原始结果：

它可以使用类和 Collections ，一次创建每个条目，然后将其合并成一个结果。

It works by using Class and Collections, creating each entry one at a time, and then putting it together for the results.

我使用数组来收集和输出数据，因为这将工作很多更快。在你的原件中，你有一些字体着色，我已经结束了。

I use arrays to collect and output the data, because this will work much faster. In your original you had some font coloring, which I have carried over.

你应该能够适应你的真实数据，但如果你不能，我建议您在某些文件共享网站（如DropBox，OneDrive等）上发布原始数据的已清理副本以及正确的列等等;并在这里发布一个链接，所以我们可以看到真实的东西

You should be able to adapt it to your real data, but, if you cannot, I suggest you post a "sanitized" copy of your original data, with the correct columns and so forth, on some file sharing web site such as DropBox, OneDrive, etc; and post a link here so we can see the "real stuff"

关于使用类，请参阅 Chip Pearson的网站

另外，请阅读代码中的注释说明和建议。

Also, please read the comments in the code for explanations and suggestions.

首先插入一个类模块，将其重命名为 cOfcCode ，然后粘贴下面的代码：

First insert a Class Module, ReNAME it cOfcCode and paste the code below into it:

'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



Then, in a regular module:

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

在代码中对Worksheet引用进行更改（只需在常规模块的开头执行此操作即可。

Make the changes to the Worksheet references in the code (only need to do that at the beginning of the regular module.

首先在您的原始示例中尝试这样做，以便您可以看到它的工作原理，然后添加额外的列和处理到类和集合，或发回到这里更多细节

Try this first on your original example, so you can see how it works, then add in the extra columns and processing to the Class and the Collection, or post back here with more details

相关推荐