Question

我需要创建一个VB代码，但是自从我上大学以来我必须这样做。

我有image1中显示的excel工作表，我需要创建一个代码，它将有条件地合并这些行，如image2所示。

你能帮忙吗？

谢谢：）

Answer 1

测试一下。

     Sub test()
        Dim rngDB As Range, rng As Range
        Dim rngO As Range, myCell As Range
        Dim n As Integer

        With Application
            .ScreenUpdating = False
            .DisplayAlerts = False
        End With
        Set rngDB = Range("a2", Range("a" & Rows.Count).End(xlUp))

        For Each rng In rngDB
            If rng <> "" Then
                n = WorksheetFunction.CountIf(rngDB, rng)
                Set rngO = rng.Offset(, 1).Resize(n)
                For Each myCell In rngO
                    If myCell <> "" Then
                        myCell.Resize(WorksheetFunction.CountIf(rngO, myCell)).Merge
                    End If
                Next myCell
                rng.Resize(n).Merge
            End If
        Next rng
         With Application
            .ScreenUpdating = True
            .DisplayAlerts = True
        End With

    End Sub

或测试此

 Sub test2()
    Dim rngDB As Range, rng As Range
    Dim rngO As Range, myCell As Range
    Dim rngU As Range, s
    Dim n As Integer

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    Set rngDB = Range("a2", Range("a" & Rows.Count).End(xlUp))

    For Each rng In rngDB
        If rng <> "" Then
            n = WorksheetFunction.CountIf(rngDB, rng)
            Set rngO = rng.Offset(, 1).Resize(n)
            s = rngO(1)
            For Each myCell In rngO
                If myCell <> "" Then
                    If s = myCell Then
                        If rngU Is Nothing Then
                            Set rngU = myCell
                        Else
                            Set rngU = Union(rngU, myCell)
                        End If
                    Else
                        rngU.Merge
                        Set rngU = myCell
                        s = myCell
                    End If
                End If
            Next myCell
            rngU.Merge
            Set rngU = Nothing
            rng.Resize(n).Merge
        End If
    Next rng
     With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

End Sub

Answer 2

Dy.Lee我非常感谢你的回答，非常感谢。

如果我有1列数据，那么Sub test2（）有效，但我真正想要的是在多个单元格中执行此操作，例如在单元格B和单元格C以及单元格D中同时执行此操作

请查看下面的图片

真的再次感谢。

image

Excel VBA条件行合并

2 个答案: