как объединить ячейки с одинаковым значением в один ряд

Question

Как объединить ячейки с одинаковым значением и цветом в строке?

, и результат должен быть:

Answer 1

Я думаю, вы могли бы попробовать это:

Option Explicit

Sub test()

    Dim LastRow As Long, i As Long, Value As Long
    Dim Color As Double

    With ThisWorkbook.Worksheets("Sheet1")

        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

        For i = LastRow To 2 Step -1

            Value = .Range("A" & i).Value
            Color = .Range("A" & i).Interior.Color

            If .Range("A" & i - 1).Value = Value And .Range("A" & i - 1).Interior.Color = Color Then
                .Rows(i).EntireRow.Delete
            End If

        Next i

    End With

End Sub

Answer 2

Создайте пользовательскую функцию в редакторе Visual Basic, которая будет возвращать индекс цвета ячейки:

Function COLOR(Target As Range)
    COLOR = Target.Interior.ColorIndex
End Function

Затем в правом столбце используйте формулу, подобную этой:

=IF(OR(A2<>A3,COLOR(A2)<>COLOR(A3)),1,0)

Затем отфильтруйте, чтобы показать только 1.

Answer 3

Копировать последовательно в один

• Настройте значения в разделе констант в соответствии со своими потребностями.
• Изображение выглядит так, как будто вы хотите, чтобы все это происходило в одном столбцетот же рабочий лист, который настраивается в разделе констант.
• Перед записью в целевой столбец (cTgtCol) код очистит его содержимое.Будьте осторожны, чтобы не потерять данные.
• Цвета применяются с использованием цикла, что замедляет процесс копирования данных с использованием быстрого массива.

Код

Sub CopyConsecutiveToOne()

    ' Source
    Const cSource As Variant = "Sheet1"   ' Worksheet Name/Index
    Const cSrcCol As Variant = "A"        ' Column Letter/Number
    Const cSrcFR As Long = 1              ' Column First Row Number
    ' Target
    Const cTarget As Variant = "Sheet1"   ' Worksheet Name/Index
    Const cTgtCol As Variant = "A"        ' Column Letter/Number
    Const cTgtFR As Long = 1              ' Column First Row Number

    Dim rng As Range      ' Source Column Last Used Cell Range,
                          ' Source Column Range, Target Column Range
    Dim vntS As Variant   ' Source Array
    Dim vntT As Variant   ' Target Array
    Dim vntC As Variant   ' Color Array
    Dim i As Long         ' Source Range/Array Row/Element Counter
    Dim k As Long         ' Target/Color Array Element Counter

    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    'On Error GoTo ProcedureExit

    ' In Source Worksheet
    With ThisWorkbook.Worksheets(cSource).Columns(cSrcCol)
        ' Calculate Source Column Last Used Cell Range.
        Set rng = .Find("*", , xlFormulas, xlWhole, xlByColumns, xlPrevious)
        ' Check if data in Source Column.
        If Not rng Is Nothing Then  ' Data found.
            ' Calculate Source Range.
            Set rng = .Range(.Cells(cSrcFR), .Cells(rng.Row))
            ' Copy values from Source Range to Source Array.
            vntS = rng
          Else                      ' Data Not Found.
            With .Cells(1)
                MsgBox "No Data in column '" & .Split(.Address, "$")(1) & "'."
                GoTo ProcedureExit
            End With
        End If
    End With

    ' In Arrays
    ' Count the number of elements in Target/Color Array.
    k = 1 ' The first element will be included before the loop.
    ' Loop through elements of Source Array.
    For i = 2 To UBound(vntS)
        ' Check if current value is different then the previous one.
        If vntS(i, 1) <> vntS(i - 1, 1) Then
            ' Count element of Target/Color Array.
            k = k + 1
        End If
    Next

    ' Write to Target/Color Arrays
    ' Resize Target/Color Arrays.
    ReDim vntT(1 To k, 1 To 1)
    ReDim vntC(1 To k, 1 To 1)
    ' Reset Counter
    k = 1 ' The first element will be included before the loop.
    ' Write first value from Source Array to Target Array.
    vntT(1, 1) = vntS(1, 1)
    ' Write first color value to Target Color Array.
    vntC(1, 1) = rng.Cells(1, 1).Interior.Color
    ' Loop through elements of Source Array.
    For i = 2 To UBound(vntS)
        ' Check if current value is different then the previous one.
        If vntS(i, 1) <> vntS(i - 1, 1) Then
            ' Count element of Target/Color Array.
            k = k + 1
            ' Write from Source Array to Target Array.
            vntT(k, 1) = vntS(i, 1)
            ' Write color values from Source Range to Color Array.
            vntC(k, 1) = rng.Cells(i, 1).Interior.Color
        End If
    Next

    ' All necessary data is in Target/Color Arrays.
    Erase vntS
    Set rng = Nothing

    ' In Target Worksheet
    With ThisWorkbook.Worksheets(cTarget).Cells(cTgtFR, cTgtCol)
        ' Clear contents of range from Target First Cell to Target Bottom Cell.
        .Resize(Rows.Count - .Row + 1).ClearContents
        ' Calculate Target Column Range.
        Set rng = .Resize(k)
        ' Copy Target Array to Target Range.
        rng = vntT
        ' Apply colors to Target Range.
        With rng
            ' Loop through cells of Target Column Range.
            For i = 1 To k
                ' Apply color to current cell of Target Range using the values
                ' from Color Array.
                .Cells(i, 1).Interior.Color = vntC(i, 1)
            Next
        End With
    End With


ProcedureExit:
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

End Sub