连续复制到一个

Question

如何连续合并具有相同值和颜色的单元格？

，结果应为：

Answer 1

连续复制到一个

调整常量部分中的值以适合您的需求。
图像看起来像您希望所有这些都发生在同一列中相同的工作表，在常量部分进行了调整。
在写入目标列（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

Answer 2

我认为您可以尝试以下方法：

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 3

在Visual Basic编辑器中创建一个自定义函数，该函数将返回到单元格的颜色索引：

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

然后在右列中使用类似于以下的公式：

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

然后过滤器仅显示1。

如何在一行中合并具有相同值的单元格

3 个答案:

连续复制到一个

代码