使用 Excel-VBA 在多行中拆分单元格值并在下一列中连接这些值且格式完整的更好方法

Question

这是我的 excel sheet 的观点：

文档概述：

它有多个列，可能会根据 requirement.Document ID 和文档版本在每个 sheet 中始终可用，但是列的名称（例如；文档 ID 或 ID / 文档版本或文档编号）和栏目（例如；G 栏和 H 栏/J 栏和 K 栏）可能会有所不同。

在这种情况下，文档 ID - C 列和文档版本 - D 列可能在每个单元格中包含多个值。

文档 ID 始终有 9 位数字（如果 Id 没有足够的数字，则用尾随零填充）。前任; 000987094、123456100、234567899、023456789 等

文档版本总是固定格式为“0.0”或“00.0”，例如； 1.0、23.0、2.1 等

我目前所做的描述：

我使用 VBA 宏将包含多个值（ID 和相关版本，在上传图片中突出显示）的单元格拆分为它们下面的行。之后，我通过手动插入一个新列然后使用另一个宏来连接，将拆分值连接到下一列。

这是我运行宏后的输出：

宏：

    Sub SplitCellValuesIntoRows()

        Dim rng_all_data As Range
        'Set rng_all_data = Application.InputBox(prompt:="Select the Range of cells:", Type:=8)
        Set rng_all_data = ActiveSheet.UsedRange
        Dim int_row As Integer
        int_row = 0

        On Error Resume Next

        Dim sht_out As Worksheet
        Set sht_out = Worksheets.Add

        Dim rng_row As Range
        For Each rng_row In rng_all_data.Rows

            Dim int_col As Integer
            int_col = 0

            Dim int_max_splits As Integer
            int_max_splits = 0

            Dim rng_col As Range
            For Each rng_col In rng_row.Columns

                Dim col_parts As Variant
                col_parts = Split(rng_col, vbLf)

                If UBound(col_parts) > int_max_splits Then
                    int_max_splits = UBound(col_parts)
                End If

                 sht_out.Range("A1").Offset(int_row, int_col).Resize(UBound(col_parts) + 1) = Application.Transpose(col_parts)

                int_col = int_col + 1
            Next

            int_row = int_row + int_max_splits + 1
        Next

    End Sub



Sub Join_em()

    For i = 2 To ActiveSheet.UsedRange.Rows.Count
        Range("E" & i).Formula = (Range("C" & i).Value & " " & Range("D" & i).Value)
    Next i

End Sub

在宏Join_em()中，我在使用第一个宏SplitCellValuesIntoRows()后手动填充值，根据文档ID和文档版本的输出列来获得连接值。

Range("E" & i).Formula = (Range("C" & i).Value & " " & Range("D" & i).Value)

在这种情况下，

C、D 和 E。

我想达到的目标：

我正在尝试实现类似这样的输出：

通过在相同的sheet中添加行来拆分具有多个值的单元格，并保持目标单元格格式完整。
添加一个新列 E（在本例中）并将文档 ID 和文档版本中的值与前导零和尾随零完好无损
由于文档 ID（9 位 with/without 尾随零）和文档版本（“0.0”或“00.0”）的格式始终是固定的，但名称和列号不固定，是吗在将多个单元格值拆分为单独的行后，可以使用正则表达式并将各个单元格自动组合到它们旁边新插入的列中。（如果知道如何让它工作就太棒了，我试过没有成功。我不知道让它工作的逻辑）

这是用于下载虚拟 Excel Sheet 的 link，以备不时之需。

DummyBook.xlsx

Answer 1

您可以将范围或 sheet（不是 "Entire Workbook"）保存为 "Web Page (.htm;.html)"，并在 Excel 中打开生成的 .htm 文件。之后，您可以取消合并所有单元格并根据需要添加边框：

Answer 2

查找您的专栏

Regex 解决方案在您寻找复杂的字符串组合时非常有用，但在 VBA 中它们可能有点慢。考虑到匹配模式的简单性，使用更多 'primitive' 字符串比较可能会更容易和更快。例如，假设您的文档 ID 在 10000 到 1000000000 之间，您可以简单地尝试将字符串转换为 Long 并查看该值是否在这些数字之间。可以使用类似的方法来比较小数点的每一侧以进行文档版本比较。

对于任何字符串比较，Regex 或其他，您需要防止错误匹配。例如，单元格 "A3" 的值与文档版本的模式匹配。所以你需要采取一些保护措施来防止你的代码选择错误的列；只有您会知道那些可能是可靠的，但它可能就像说文档版本只能出现在列 "C" 或之后一样简单。

连接值

在您的电子表格中，所有单元格的格式都为 Text。这意味着偶数将被解释为字符串 - 因此在 ID 和 Version 单元格中会出现绿色小三角警告您。如果它们是数字，那么您需要对这些单元格应用数字格式（例如 #0.# 表示版本）。对于您的电子表格，串联并不比在 str = str1 & " " & str2.

中连接两个字符串更复杂

在你的第二张图片中，看起来你有一个 General 单元格格式（或者可能是某种数字格式），所以这些值被解释为数字。这些需要在连接之前使用 NumberFormat() 函数进行格式化。

拆分行

将单元格拆分成行虽然在语法上很简单，但是当您试图跟踪正在调查的行时可能会很麻烦。我这样做的方法是将相关行存储在 Collection 中，并且在需要时不断引用这些集合对象。这样做的好处是 Collection 中的 Range 引用会在添加行时自行更新。

总而言之，您的代码相对简单，下面给出了它如何工作的示例。您会注意到，我没有为新行和新列设置格式而烦恼——这相当简单，您可以根据自己的需要自行完成。此代码应放在模块中：

Option Explicit

Private Const ID_IDX As Long = 0
Private Const VER_IDX As Long = 1
Private Const RNG_IDX As Long = 2

Private Sub RunMe()
    Dim data As Variant, cols As Variant, items As Variant
    Dim r As Long, c As Long, i As Long, n As Long
    Dim ids() As String, vers() As String
    Dim addItems As Collection, concatItems As Collection
    Dim dataRng As Range, rng As Range
    Dim writeID() As Variant, writeVer() As Variant, writeConcat() As Variant
    Dim dataStartRow As Long

    'Define the range we're interested in and read into an array.
    With Sheet1 'adjust for your worksheet object
        Set dataRng = .Range(.Cells(1, "A"), .Cells(.Rows.Count, "A").End(xlUp)) _
                      .Resize(, .Cells(1, .Columns.Count).End(xlToLeft).Column)
       End With
    data = dataRng.Value2
    dataStartRow = 2

    'Find the two target columns
    cols = AcquireIdAndVerCol(data, 3, 8)
    If IsEmpty(cols) Then
        MsgBox "Unable to find Id and Ver columns."
        Exit Sub
    End If

    With dataRng
        'Add a column next to the version number column.
        .Columns(cols(VER_IDX)).Offset(, 1).Insert Shift:=xlShiftToRight, CopyOrigin:=xlFormatFromLeftOrAbove

        'Add a column to our range.
        'This is to cover the case that the rightmost column is the version number column.
        Set dataRng = .Resize(, .Columns.Count + 1)
    End With

    'Find the rows that need to be split and concatenate the target strings.
    Set addItems = New Collection
    Set concatItems = New Collection
    For r = dataStartRow To UBound(data, 1)

        ids = Split(data(r, cols(ID_IDX)), vbLf)
        vers = Split(data(r, cols(VER_IDX)), vbLf)
        n = IIf(UBound(ids) >= UBound(vers), UBound(ids), UBound(vers))

        If n = 0 Then 'it's just one line of text.

            'Add concatenated text to list.
            concatItems.Add data(r, cols(ID_IDX)) & " " & data(r, cols(VER_IDX))

        ElseIf n > 0 Then 'it's multiple lines of text.

            'Transpose the id array.
            ReDim writeID(1 To UBound(ids) + 1, 1 To 1)
            For i = 0 To UBound(ids)
                writeID(i + 1, 1) = ids(i)
            Next
            'Transpose the version array.
            ReDim writeVer(1 To UBound(vers) + 1, 1 To 1)
            For i = 0 To UBound(ids)
                writeVer(i + 1, 1) = vers(i)
            Next

            'Add concatenated text to list.
            For i = 0 To n
                concatItems.Add (IIf(UBound(ids) <= n And UBound(vers) <= n, ids(i) & " " & vers(i), Empty))
            Next

            'Add the range to be split to the collection.
            addItems.Add Array(writeID, writeVer, dataRng.Rows(r + 1).Resize(n))

        Else 'it's an empty cell

            'Add empty item to concatenated list in order to keep alignment.
            concatItems.Add Empty

        End If

    Next

    Application.ScreenUpdating = False

    'Split the ranges in the list.
    If addItems.Count > 0 Then
        For Each items In addItems
            'Add the rows.
            With items(RNG_IDX)
                .Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                Set rng = .Offset(-.Rows.Count - 1).Resize(.Rows.Count + 1)
                'Note: format your rng Range obect as desired here.
            End With
            'Write the id and version values.
            rng.Columns(cols(ID_IDX)).Value = items(ID_IDX)
            rng.Columns(cols(VER_IDX)).Value = items(VER_IDX)
        Next
    End If

    'Write the concatenated values.
    If concatItems.Count > 0 Then
        ReDim writeConcat(1 To concatItems.Count + dataStartRow - 1, 1 To 1)
        'Header to array.
        writeConcat(1, 1) = "Concat values"
        'Values from the collection to array.
        i = dataStartRow
        For Each items In concatItems
            writeConcat(i, 1) = items
            i = i + 1
        Next
        'Output array to range.
        With dataRng.Columns(cols(VER_IDX) + 1)
            .Value = writeConcat
            .AutoFit
        End With
    End If

    Application.ScreenUpdating = True
End Sub

Private Function AcquireIdAndVerCol(data As Variant, minCol As Long, maxCol As Long) As Variant
    Dim result(1) As Long
    Dim r As Long, c As Long, i As Long
    Dim items() As String

    'Check we're not operating outside bounds of data array.
    If minCol < LBound(data, 2) Then minCol = LBound(data, 2)
    If minCol > UBound(data, 2) Then minCol = UBound(data, 2)
    If maxCol < LBound(data, 2) Then maxCol = LBound(data, 2)
    If maxCol > UBound(data, 2) Then maxCol = UBound(data, 2)

    'Loop through data to find the two columns.
    'Once found, leave the function.
    For r = 1 To UBound(data, 1)
        For c = minCol To maxCol
            items = Split(data(r, c), vbLf)
            For i = 0 To UBound(items)
                If result(ID_IDX) = 0 Then
                    If IsDocId(items(i)) Then
                        result(ID_IDX) = c
                        If result(VER_IDX) = 0 Then
                            Exit For
                        Else
                            AcquireIdAndVerCol = result
                            Exit Function
                        End If
                    End If
                End If
                If result(VER_IDX) = 0 Then
                    If IsDocVer(items(i)) Then
                        result(VER_IDX) = c
                        If result(ID_IDX) = 0 Then
                            Exit For
                        Else
                            AcquireIdAndVerCol = result
                            Exit Function
                        End If
                    End If
                End If
            Next
        Next
    Next

End Function
Private Function IsDocId(val As String) As Boolean
    Dim n As Long

    n = TryClng(val)
    IsDocId = (n > 9999 And n <= 999999999)
End Function

Private Function IsDocVer(val As String) As Boolean
    Dim n As Long, m As Long
    Dim items() As String

    items = Split(val, ".")
    If UBound(items) <> 1 Then Exit Function

    n = TryClng(items(0))
    m = TryClng(items(1))

    IsDocVer = (n > 0 And n <= 99) And (m >= 0 And m <= 9)
End Function

'-------------------------------------------------------------------
'Converts a variant to a Long or returns a fail value as a Long
'if the conversion failed.
'-------------------------------------------------------------------
Private Function TryClng(expr As Variant, Optional fail As Long = -1) As Long
    Dim n As Long

    n = fail
    On Error Resume Next
    n = CLng(expr)
    On Error GoTo 0

    TryClng = n
End Function

使用 Excel-VBA 在多行中拆分单元格值并在下一列中连接这些值且格式完整的更好方法

Better method to Split Cell values in multiple Rows and Concatenate these values in the next Column with formatting intact using Excel-VBA

excel

vba

excel-2013