Excel 如何使用vba合并相同的值列？

谁能帮我写一个vba代码来合并不同列中的相同值单元格，如下所示

我尝试过使用下面的代码，但不起作用

Sub mergeWeeks()
    Dim lc As Long, nc As Long, cr As Long, rng As Range

    Application.DisplayAlerts = False

    With Worksheets("sheet2")
        For cr = 1 To 2
            lc = Application.Match("zzz", .Rows(cr))
            Set rng = .Cells(cr, 1)
            Do While rng.Column < lc
                nc = Application.Match(rng.Value & "z", .Rows(cr))
                rng.Resize(1, nc - rng.Column + 1).Merge
                Set rng = rng.Offset(0, 1)
            Loop
        Next cr
    End With

    Application.DisplayAlerts = True

End Sub

---

使用Range.Find with xlPrevious应环绕工作表行，以查找最后一次出现的值

Option Explicit

Sub mergeSame()

    Dim r As Long, c As Long, c2 As Long

    r = 3   'row with 'Year'
    c = 1   'column with 'Year'

    With Worksheets("sheet3")

        Do While Not IsEmpty(.Cells(r, c))
            c2 = .Rows(r).Cells.Find(What:=.Cells(r, c).Value, After:=.Cells(r, c), _
                                     MatchCase:=False, LookAt:=xlWhole, _
                                     SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Column
            If c2 > c Then
                With .Cells(r, c).Resize(2, 1)
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .WrapText = False
                End With
                With .Range(.Cells(r, c), .Cells(r, c2))
                    Application.DisplayAlerts = False
                    .Offset(1, 0).Merge
                    .Merge
                    Application.DisplayAlerts = True
                End With
            End If

            c = c2 + 1
        Loop

    End With

End Sub

当值相同时，水平合并单元格

As Range.Find在查找上次使用的列时出错，如果该列位于合并单元格内。因此，我使用标准的UsedRange来查找它，即使在合并单元格时也是如此。

按行合并 链接 特征 工作表参数cSheet可以作为名称或索引输入。 您可以添加任意多个不连续的行。微调功能 即使存在意外空间，也能确保正确的功能 在逗号和行号之间。 第一列可以输入字母或数字cFirstC，而 正在第一行计算最后一列LastC。 合并中的范围合并rngU和非合并中的阵列vntAA的3D阵列应确保极大的效率。 合并联合版本 取消合并三维阵列版本

---

这带来了一个错误对象变量或未设置块变量。您试图修改的工作表的名称是什么？该代码是在我从您的数据映像创建的示例数据上测试的。我无法解释为什么它对你不起作用。取消合并的代码是什么？我想在合并和不合并之间切换。@Kinsman K:没那么简单。我现在正在做另一个项目。也许几小时后或者明天。如果你赶时间，就再问一个问题。@Kinsman K:对不起，我等了这么久，花了好几个小时才研究完任务的各个方面。我还在合并脚本中实现了一个小的更改

Sub mergeCells()
    Dim ws As Worksheet
    Dim UsedColumns As Long
    Dim rng As Range
    Dim CurrentRow As Long, CurrentColumn As Long

    Set ws = ActiveWorkbook.Worksheets("sheet3")
    UsedColumns = ws.Cells.Find(What:="*", LookIn:=xlFormulas, _
        SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    Application.DisplayAlerts = False

    For CurrentRow = 1 To 2
        For CurrentColumn = UsedColumns To 2 Step -1
            Set rng = ws.Cells(CurrentRow, CurrentColumn)
            If rng.Value <> "" And rng.Value = rng.Offset(0, -1).Value Then
                rng.Offset(0, -1).Resize(1, 2).Merge
            End If
        Next CurrentColumn
    Next CurrentRow
    Application.DisplayAlerts = True

    set rng = Nothing
    Set ws = Nothing
End Sub

Sub UnmergeCells()
    Dim ws As Worksheet
    Dim UsedColumns As Long
    Dim rng As Range
    Dim cellcount As Long
    Dim CurrentRow As Long, CurrentColumn As Long

    Set ws = ActiveWorkbook.Worksheets("sheet3")
    UsedColumns = ws.UsedRange.Cells(1).Column + ws.UsedRange.Columns.Count - 1

    For CurrentRow = 1 To 2
        For CurrentColumn = 1 To UsedColumns
            Set rng = ws.Cells(CurrentRow, CurrentColumn)
            If rng.Value <> "" And rng.MergeCells Then
                cellcount = rng.MergeArea.Cells.Count
                rng.MergeArea.UnMerge
                rng.Resize(1, cellcount).Value = rng.Value
            End If
        Next CurrentColumn
    Next CurrentRow

    Set rng = Nothing
    Set ws = Nothing
End Sub

Sub MergeInRows()

    Const cSheet As Variant = "Sheet2"  ' Worksheet Name/Index
    Const cRows As String = "1,2"       ' Merge Rows List
    Const cFirstC As Variant = "B"      ' First Column Letter/Number

    Dim rngU As Range     ' Union Range
    Dim vntR As Variant   ' Merge Rows Array
    Dim LastC As Long     ' Last Column
    Dim CurrR As Long     ' Current Row
    Dim i As Long         ' Rows Counter
    Dim j As Long         ' Columns Counter

    Application.DisplayAlerts = False

    vntR = Split(cRows, ",")

    With ThisWorkbook.Worksheets(cSheet)
        LastC = .Rows(CLng(Trim(vntR(0)))).Find("*", , -4123, , 1, 2).Column
        For i = 0 To UBound(vntR)
            CurrR = CLng(Trim(vntR(i)))
            Set rngU = .Cells(CurrR, cFirstC)
            For j = .Cells(1, cFirstC).Column + 1 To LastC
                If .Cells(CurrR, j) = .Cells(CurrR, j - 1) Then
                    Set rngU = Union(rngU, .Cells(CurrR, j))
                  Else
                    With rngU
                        .Merge
                    End With
                    Set rngU = .Cells(CurrR, j)
                End If
            Next
            If rngU.Columns.Count > 1 Then rngU.Merge
        Next

    End With

    Application.DisplayAlerts = True

End Sub

Sub UnMergeInRows()

    Const cSheet As Variant = "Sheet2"  ' Worksheet Name/Index
    Const cRows As String = "1,2"       ' Merge Rows List
    Const cFirstC As Variant = "B"      ' First Column Letter/Number

    Dim CurrRng As Range  ' (Current) Merge Row Range
    Dim vntR As Variant   ' Merge Row Array
    Dim vntAA As Variant  ' Merge Range Arrays Array
    Dim vntT As Variant   ' Temporary AA Container
    Dim LastC As Long     ' Last Column
    Dim CurrR As Long     ' Current Row
    Dim i As Long         ' Merge Row- and Merge Range Arrays- Array Row Counter
    Dim j As Long         ' Border Row- and Merge Range Arrays- Array Columns Counter

    Application.DisplayAlerts = False

    vntR = Split(cRows, ",")
    ReDim vntAA(UBound(vntR))

    With ThisWorkbook.Worksheets(cSheet)
        LastC = .Rows(CLng(Trim(vntR(0)))).Find("*", , -4123, , 1, 2).Column
        LastC = LastC + .Cells(CLng(Trim(vntR(0))), LastC) _
                .MergeArea.Columns.Count - 1
        ' Copy Merge Row Ranges to Merge Range Arrays Array.
        For i = 0 To UBound(vntR)
            CurrR = CLng(Trim(vntR(i)))
            Set CurrRng = .Range(.Cells(CurrR, cFirstC), .Cells(CurrR, LastC))
            With CurrRng
                ' Apply formatting to (Current) Merge Row Range.
                .UnMerge
                For j = 7 To 11
                    With .Borders(j)
                        .LineStyle = xlContinuous
                        .Weight = xlThin
                        .ColorIndex = xlAutomatic
                    End With
                Next
            End With
            ' Copy (Current) Merge Row Range to Merge Range Arrays Array.
            vntAA(i) = CurrRng
        Next

        ' Manipulate data in Merge Range Arrays Array.
        For i = 0 To UBound(vntR)
            vntT = vntAA(i)(1, 1)
            For j = 2 To UBound(vntAA(i), 2)
                If vntAA(i)(1, j) = "" Then
                    vntAA(i)(1, j) = vntT
                  Else
                    vntT = vntAA(i)(1, j)
                End If
            Next
        Next

        ' Copy Merge Range Arrays to Merge Ranges.
        For i = 0 To UBound(vntR)
            .Cells(CLng(Trim(vntR(i))), cFirstC) _
                    .Resize(, UBound(vntAA(i), 2)) = vntAA(i)
        Next

    End With

    Application.DisplayAlerts = True

End Sub