时间戳

首页 > 解决方案 > 以不同颜色突出显示副本（并连接整行）EXCEL

excel - 以不同颜色突出显示副本（并连接整行）EXCEL

问题描述

我有一张关于订单详细信息的表格。在 G 列中，一个特定的值表示订单包装在哪个容器（运输容器）中。屏幕截图

  1. 我想要所有重复的容器号。用不同的颜色和它们的行突出显示。

含义：当我有“容器号 X”时，连接到 X 的整行是一种颜色，连接到“容器号 Y”的行是另一种颜色，依此类推。

  1. 我还想在发生变化或点击数据栏中的“更新值”时自动更新颜色

  2. G 列中的空白单元格不应着色。

这可能吗，如果可以，有人可以帮助我。我是 VBA 的初学者。

Sub ColorCompanyDuplicates()
'Updateby Extendoffice
Dim xRg As Range
Dim xTxt As String
Dim xCell As Range
Dim xChar As String
Dim xCellPre As Range
Dim xCIndex As Long
Dim xCol As Collection
Dim I As Long
On Error Resume Next
If ActiveWindow.RangeSelection.Count > 1 Then
xTxt = ActiveWindow.RangeSelection.AddressLocal
Else
xTxt = ActiveSheet.UsedRange.AddressLocal
End If
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
xCIndex = 2
Set xCol = New Collection
For Each xCell In xRg
On Error Resume Next
If xCell.Value <> "" Then
xCol.Add xCell, xCell.Text
If Err.Number = 457 Then
xCIndex = xCIndex + 1
Set xCellPre = xCol(xCell.Text)
If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
ElseIf Err.Number = 9 Then
MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
Exit Sub
End If
On Error GoTo 0
End If
Next
End Sub

标签： excelvbacolorsduplicates

解决方案

此代码执行数字 1 和 3。

此外，它只使用明亮的颜色。

在此处输入图像描述

Sub ColorCompanyDuplicates()

Dim row_start As Long, last_row As Long, color_index As Long
Dim R As Long, last_col As Long, col As Long
Dim used_range As Range, paint_row As Boolean

'CONFIG -------------------------
row_start = 5 'first row of the data set
paint_row = True 'set to false if you want to paint only the column
'--------------------------------

color_index = 33
Set used_range = ActiveSheet.UsedRange

last_col = _
used_range.Columns.Count + used_range.Column - 1

last_row = _
Cells(Rows.Count, 7).End(xlUp).Row

'clean existing rows in container names
For R = row_start To last_row
    If Range("g" & R) <> "" Then
        Range("g" & R).Value = Split(Range("g" & R).Value, " ")(0)
    End If
Next R

'paint duplicates
For R = row_start To last_row

    'if the next container name is the same and is not null then paint
    If Cells(R, 7) = Cells(R + 1, 7) And Cells(R, 7) <> "" Then
        
        If paint_row Then
        
            For col = used_range.Column To last_col
                Cells(R, col).Interior.ColorIndex = color_index
            Next col
            
            Else
            For col = used_range.Column To last_col
                Cells(R, col).Interior.ColorIndex = 0
            Next col
            Cells(R, 7).Interior.ColorIndex = color_index
            
        End If
        
    'FOR THE LAST ONE in the group
    'if previews container name is the same and is not null then paint
    ElseIf Cells(R, 7) = Cells(R - 1, 7) And Cells(R, 7) <> "" Then
        
        If paint_row Then
            
            For col = used_range.Column To last_col
                Cells(R, col).Interior.ColorIndex = color_index
            Next col
            
            Else
            For col = used_range.Column To last_col
                Cells(R, col).Interior.ColorIndex = 0
            Next col
            Cells(R, 7).Interior.ColorIndex = color_index
            
        End If
        
        'and change color for the next group
        color_index = color_index + 1
        
        'avoid dark colors
        If color_index = 46 Then
            color_index = 33
        End If
        
    End If
    
Next R

'add row numbers to containers name
For R = row_start To last_row
      If Range("g" & R) <> "" Then
        Cells(R, 7) = Cells(R, 7) & " ROW:" & R
     End If
Next R

End Sub

我建议为 2 号创建一个刷新按钮或命令快捷方式。

推荐阅读