Excel VBA條件行合並

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中

請檢查下面的圖片

真的非常感謝。

圖片