合并成行

Question

任何人都可以帮我编写一个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

screen shot

Answer 1

使用Range.Find与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

Answer 2

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

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

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

如果足以比较这些值（例如，每个“ jan”都是相同的字符串），则上面的代码有效。
如果月份基于不同日期的单元格格式（例如，12月1日，12月8日，12月15日...全部显示为“ 12月”或“ 12”），则可以将Month(rng.Value)与{{1 }}。

取消合并

Month(rng.Offset(0, -1).Value)

如果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在合并的单元格中，则很难找到最后使用的列。因此，即使合并了单元格，我也使用标准的Range.Find来找到它。

Answer 3

合并成行

链接

Workbook Download: "how-do-you-merge-same-value-columns-using-vba_54279695.xls"

Another 3D Array Example on SO: Array of Arrays feat. 3-dimensional Jagged Arrays

功能

可以将工作表参数（cSheet）作为名称或索引输入。
您可以根据需要添加（cRows）个（非）连续的行。 Trim函数即使有（偶然）空格，也可以确保正确的功能在逗号和行号之间。
第一列可以输入字母或数字（cFirstC），而最后一行（LastC）正在第一行中计算。
MERGE中的范围合并（rngU）和UNMERGE中的3D数组阵列（vntAA）应该确保高效率。

合并联盟版本

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

取消合并3D阵列版本

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

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

3 个答案:

合并成行

链接

功能

合并联盟版本

取消合并3D阵列版本