Как вы объединяете столбцы одинакового значения, используя VBA?

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

Answer 1

объединить ячейки по горизонтали, когда значение идентично

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" - это просто одна и та же строка), тогда приведенный выше код работает.
Если месяц основан на формате ячейки с разными датами (например, 1-е декабря, 8-е декабря, 15-е декабря ... все показанокак "dec" или "12"), тогда вы можете сравнить Month(rng.Value) с Month(rng.Offset(0, -1).Value).

Unmerge

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 плохов поиске последнего использованного столбца, если он находится в объединенных ячейках.Поэтому вместо этого я использую стандарт UsedRange, чтобы найти его, даже когда ячейки объединены.

Answer 2

Объединение в строки

Ссылки

Загрузка рабочей книги: "how-do-you-you-merge-same-value-columns-using-using-vba_54279695.xls"

Еще один пример 3D-массива для SO: Array of Arrays feat.Трехмерные зубчатые массивы

Особенности

• Параметр листа (cSheet) можно ввести как имя или индекс.
• Вы можете добавить каксколько угодно (не) смежных строк (cRows).Функция Trim обеспечивает правильную работу, даже если между запятыми и номерами строк есть (случайные) пробелы.
• Первый столбец можно вводить как букву или цифру (cFirstC), а последний столбец (* 1024)*) вычисляется в первом ряду.
• Range Union (rngU) в MERGE и трехмерный массив массивов (vntAA) в UNMERGE должны обеспечивать большую эффективность.

Версия Merge Union

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

Версия UnMerge 3D Array

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

Answer 3

Использование 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