在列VBA中合并具有相似值的行

Question

我在Stack Overflow上找到了一个代码，它合并了A列中具有相同值的行，但是我不能修改它的代码以合并A列中具有相似值的行。

例如：

代码运行后，合并或合并的行应该具有，但是它的作用是将A列中的每个值视为唯一值：

结果应为：101 102 12

请有人帮助我修改或共享一个代码，以合并列A中具有相似值的行。谢谢！

   Sub CombineRows()

    Dim Rng As Range, _
                    Dn As Range _
                    , N As Long _
                    , nRng As Range

    On Error Resume Next

    Set Rng = Range(Range("A2"), Range("A" & Rows.count).End(xlUp))
    With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare

    For Each Dn In Rng
        If Not .Exists(Dn.Value) Then
            .Add Dn.Value, Dn
        Else
            If nRng Is Nothing Then Set nRng = _
            Dn Else Set nRng = Union(nRng, Dn)
            .Item(Dn.Value).Offset(, 2) = .Item(Dn.Value).Offset(, 2) + 
             Dn.Offset(, 2)
            .Item(Dn.Value).Offset(, 3) = .Item(Dn.Value).Offset(, 3) + 
             Dn.Offset(, 3)
            .Item(Dn.Value).Offset(, 4) = .Item(Dn.Value).Offset(, 4) + 
             Dn.Offset(, 4)


        End If
    Next
    If Not nRng Is Nothing Then nRng.EntireRow.Delete
    End With


    End Sub

@DecimalTurn的答案。我调整了字符串变量； Shortstring＆Longsting从字符串中取出所有逗号。

Dim c1 As Range, c2 As Range
    For Each c1 In Rng

        Dim ShortString  As String
        ShortString = Replace(c1.Value2, ",", "")

        For Each c2 In Rng

            If c2.row > c1.row Then 'Because we sorted the rows, we only need to look at the row if it's a row below c1.

                Dim LongString  As String
                LongString = Replace(c2.Value2, ",", "")

                If InStr(LongString, ShortString) > 0 Then

                    'Add Combine similar lines
                    c1.Offset(, 2).Value2 = c1.Offset(, 2).Value2 + c2.Offset(, 2).Value2
                    c1.Offset(, 3).Value2 = c1.Offset(, 3).Value2 + c2.Offset(, 3).Value2
                    c1.Offset(, 4).Value2 = c1.Offset(, 4).Value2 + c2.Offset(, 4).Value2

                    'Delete current line since it has a similar value as the shorter one.
                    c2.EntireRow.Delete
                End If

            End If

        Next c2
    Next c1

Answer 1

查看两个strings是否“相似”的一种简单方法是测试一个字符串是否包含在另一个字符串中。为此，您可以使用函数Sub Fill() Dim JsonText As String Dim Parsed As Dictionary file_name = "YourFile.json" my_file = FreeFile() Open file_name For Input As my_file i = 1 While Not EOF(my_file) Line Input #my_file, text_line JsonText = JsonText + text_line i = i + 1 Wend Set Parsed = JsonConverter.ParseJson(JsonText) Dim ticker, third, v As Variant Dim dict2, dict3 As Variant Dim r, c, r2 As Integer r = 2 For Each ticker In Parsed.Keys() ' AAL Set dict2 = Parsed.Item(ticker) ActiveSheet.Cells(r, 1).Value = ticker ' set ticker on first line c = 2 For Each third In dict2.Keys() ' year ActiveSheet.Cells(1, c).Value = third Set dict3 = dict2.Item(third) r2 = r For Each v In dict3 ActiveSheet.Cells(r2, 1).Value = ticker ' repeat ticker on next lines ActiveSheet.Cells(r2, c).Value = v r2 = r2 + 1 Next v c = c + 1 Next third r = r2 Next ticker 'Sheets("example").Range(Cells(1, 1), Cells(Parsed("values").Count, 3)) = Values End Sub 。

以下是使用方法的示例：

InStr

为了在2行以上实现此功能，我们可以调整您提交的代码的标准值，并将其设置为代码的第一步。此步骤确保我们已经合并了A列中具有完全相同值的行。对于步骤2 ，我们需要按A列中的值的长度进行排序，以便我们可以轻松地循环在下一步。在第3步中，我们遍历该范围（双循环），并检查较短的A列值（c1）是否出现在其下方的任何单元格（c2）中。如果是，那么我们将这两行合并。

这是它的样子：

Sub TestInstr()

    Dim txt1 As String, txt2 As String
    txt1 = ActiveSheet.Range("A1")
    txt2 = ActiveSheet.Range("A2")

    Dim Substring As String, FullString As String

    If Len(txt1) <= Len(txt2) Then

        Substring = txt1
        FullString = txt2

    Else

        Substring = txt2
        FullString = txt1

    End If


    If InStr(FullString, Substring) > 0 Then

        'This code runs when the substring is included somewhere inside the full string

    Else

        'This code runs when the substring is not included anywhere inside the full string

    End If

End Sub

要进行测试，我使用下面的宏生成了数据并获得了预期的结果：

Sub CombineRows()

    Dim ws As Worksheet
    Set ws = ActiveSheet

    Dim Rng As Range
    Set Rng = ws.Range(ws.Range("A1"), ws.Range("A" & ws.Rows.Count).End(xlUp))

    Dim RangeValues As Object
    Set RangeValues = CreateObject("Scripting.Dictionary")
    RangeValues.CompareMode = vbTextCompare

    '1) Store unique values in dictionary and combine identical rows
    Dim c As Range
    For Each c In Rng

        If Not RangeValues.Exists(c.Value) Then

            RangeValues.Add c.Value2, c

        Else

            'Add Combine identical lines
            RangeValues.Item(c.Value).Offset(, 1).Value2 = RangeValues.Item(c.Value).Offset(, 1).Value2 + c.Offset(, 1).Value2
            RangeValues.Item(c.Value).Offset(, 2).Value2 = RangeValues.Item(c.Value).Offset(, 2).Value2 + c.Offset(, 2).Value2
            RangeValues.Item(c.Value).Offset(, 3).Value2 = RangeValues.Item(c.Value).Offset(, 3).Value2 + c.Offset(, 3).Value2

            'Delete current line since it has the same value as another existing one.
            c.EntireRow.Delete

        End If

    Next

    '2) Sort the range by shortest string length
    ws.Columns("A:A").Insert Shift:=xlToRight

    For Each c In Rng
        c.Offset(0, -1).Value2 = Len(c.Value2)
    Next c

    Dim TableRange As Range
    Const NbOfColumns As Long = 5
    Set Rng = ws.Range(ws.Range("A1"), ws.Range("A" & ws.Rows.Count).End(xlUp)) 'Reset
    Set TableRange = Rng.Resize(Rng.Rows.Count, NbOfColumns + 1)

    ws.Sort.SortFields.Clear
    ws.Sort.SortFields.Add2 Key:=TableRange.Columns(1) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ws.Sort
        .SetRange TableRange
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    ws.Columns("A:A").Delete Shift:=xlToLeft

    Set Rng = ws.Range(ws.Range("A1"), ws.Range("A" & ws.Rows.Count).End(xlUp)) 'Reset

    '3) Combine similar rows (ie. rows where the shortest value is included in the longest)
    Dim c1 As Range, c2 As Range
    For Each c1 In Rng

        Dim ShortString  As String
        ShortString = c1.Value2

        For Each c2 In Rng

            If c2.Row > c1.Row Then 'Because we sorted the rows, we only need to look at the row if it's under c1.

                Dim LongString  As String
                LongString = c2.Value2

                If InStr(LongString, ShortString) > 0 Then

                    'Add Combine similar lines
                    c1.Offset(, 1).Value2 = c1.Offset(, 1).Value2 + c2.Offset(, 1).Value2
                    c1.Offset(, 2).Value2 = c1.Offset(, 2).Value2 + c2.Offset(, 2).Value2
                    c1.Offset(, 3).Value2 = c1.Offset(, 3).Value2 + c2.Offset(, 3).Value2

                    'Delete current line since it has a similar value as the shorter one.
                    c2.EntireRow.Delete
                End If

            End If

        Next c2
    Next c1

End Sub