Question

我有一个带有彩色单元格的Excel电子表格。我正在尝试构建一个VBA脚本，该脚本可以返回与预先选择的单元格颜色匹配的行号。但是，颜色是“特定于列”，这意味着它应该只匹配与所选单元格在同一列中的颜色。

例如，在附带的屏幕截图中，预先选择的单元格为A3（蓝色）和B4（红色）。

所需的返回值为：1,3,4,5。它不应返回2，因为即使B2为蓝色，但在B列中没有选择蓝色单元格。

解决此问题的最佳数据结构是什么？

以下是我的想法：

1）在单个列中，可以选择多个单元。可能存在重复的颜色。我正在考虑使用Colors字典将预先选定的颜色存储在列中。

2）由于颜色是“特定于列”，因此我考虑使用Columns字典来跟踪具有预选单元格的列。使用列号作为键，使用Colors（字典）作为值。

3）我的代码如下：

Dim objSelection As Range
Dim objSelectionArea As Range
Dim objCell As Range
Dim c, r As Long
Dim Columns As New Scripting.Dictionary
Dim Colors As New Scripting.Dictionary

' Get the current selection
Set objSelection = Application.Selection

' Walk through the areas
For Each objSelectionArea In objSelection.Areas

    ' Walk through the cells in an area
    For Each objCell In objSelectionArea
        c = objCell.Column
        r = objCell.Row
        cellColor = objCell.Interior.Color

        ' If this is a new column add it to dictionary. Also add color.
        If Not Columns.Exists(c) Then
            ' Put cell color into color dictionary as key
            Colors.Add cellColor, r
            ' Put color dictionary into column dictionary
            Columns.Add c, Colors
        ' if colomn already in dictionary, just do the color part
        ElseIf Not Columns(c).Exists(cellColor) Then
            Columns(c).Add cellColor, r
        End If
    Next

Next

' Walk through each columns that has selected cells
For Each c in Columns.Keys
    ' Walk through each cells in this column
    For r = 1 to MaxRow' Assuming MaxRow is the last row number of the table

        ' If the cell color in the the column-specific RefColor dictionary
        If Columns(c).Exists(Cells(r, c).Interior.Color) Then
        ' Do something here to indicate row r is one of the matches
        End If

    Next

Next

这个嵌套字典的问题是 - Colors字典不是“特定于列”（即使我将它嵌套在'Columns'字典中。当我将颜色存储到Colors中时，就像将颜色添加到全局/单个字体中一样因此，结果不符合业务要求。

嵌套字典是否是此问题的最佳数据结构？或者我应该使用不同的数据结构？谢谢！

Answer 1

我在这里找到答案：Excel VBA: nested dictionary issue

我是VBA的新手，所以我在原始代码中犯了一个错误。

每当向外部字典添加新密钥时，我都应该创建一个新的内部字典。

所以而不是：

Dim Colors As New Scripting.Dictionary

我应该做的：

Dim Colors As Scripting.Dictionary

然后，每当向外部字典添加新密钥时，我应该这样做：

Set Colors = New Scripting.Dictionary

Answer 2

我认为嵌套字典可以工作;虽然您必须进行一些更改才能使颜色字典真正特定于列。

请注意以下代码中的更改：

没有明确声明单个Colors字典。声明特定颜色字典意味着：
- 子/功能级变量（明显的全局字典行为）
- 添加到列字典，只需添加对现有颜色字典的其他引用
- 可以通过变量名称
相反，当单元格位于新列中时，请在“列”字典中添加新字典。这意味着：
- 每个字典“添加”到列字典中都是唯一的。
- 列级变量;而不是全球
- 不能按名称引用字典;仅通过引用Columns词典中的项目/键连接
- 在颜色字典中添加颜色的代码在列存在或不存在之间变得相同（因此，逻辑块稍有变化）
Dim c As Variant：这是您的代码隐式执行的操作。对于VBA变量，每个变量需要单独声明，或者默认为Variant
- 如果c被声明为long，则需要声明一个不同的Variant变量来循环遍历字典键。

注意：行Columns(c).Add cellColor, r将单元格颜色添加为字典中的键，将行添加为项目。这意味着如果该字体中已存在该颜色，则该项将被新行值覆盖。看一下你的代码，不应该成为一个问题（从循环到行号选择r作为行值），但我想我应该提一下，以防万一你正在计划保留最初选择的单元格的行值。

Dim objSelection As Range Dim objSelectionArea As Range Dim objCell As Range Dim c As Variant 'Made implied declaration explicit. Needs to be variant or the "for each c" loop fails Dim r As Long Dim Columns As New Scripting.Dictionary ' Get the current selection Set objSelection = Application.Selection ' Walk through the areas For Each objSelectionArea In objSelection.Areas ' Walk through the cells in an area For Each objCell In objSelectionArea c = objCell.Column r = objCell.Row cellColor = objCell.Interior.Color ' If this is a new column add it to dictionary. Also add color. ' Simplified If-End If.... If Not Columns.Exists(c) Then ' Put color dictionary into column dictionary Columns.Add c, New Scripting.Dictionary ' Creates new dictionary for each column End If ' Put cell color into color dictionary as key Columns(c).Add cellColor, r Next Next

Answer 3

我认为这是一种有效的数据结构

这使用嵌套的颜色词典，基于列

Option Explicit

Public Sub GetColColorsBasedOnSelectedRows()
    Dim ur As Range, c As Long, r As Long, rCnt As Long, cCnt As Long, sel As Range
    Dim d As Dictionary, dColors As Dictionary, cc As Long, res As String, sCell As Range

    Set ur = Sheet1.UsedRange
    rCnt = ur.Rows.Count
    cCnt = ur.Columns.Count
    Set d = New Scripting.Dictionary
    For c = 1 To cCnt   'Get all colors in all used range, by columns
        Set dColors = New Scripting.Dictionary
        For r = 1 To rCnt
            cc = ur(r, c).Interior.Color
            If InStr(1, dColors(cc), r & ", ") = 0 Then
                dColors(cc) = dColors(cc) & r & ", "
            End If
        Next
        Set d(c) = dColors
    Next
    Dim msg As String, shown As Dictionary
    Set shown = New Scripting.Dictionary
    For Each sel In Application.Selection.Areas
        For Each sCell In sel.Cells
            If Not shown.Exists(sCell.Column & "-" & sCell.Interior.Color) Then
                msg = msg & sCell.Address(0, 0) & ", "
                res = res & d(sCell.Column)(sCell.Interior.Color)
                shown(sCell.Column & "-" & sCell.Interior.Color) = 0
            End If
        Next
    Next
    Debug.Print "Selected cells: " & Left(msg, Len(msg) - 2)
    Debug.Print "Row colors:     " & Left(res, Len(res) - 2) & vbCrLf
    ShowAllItems d
End Sub

Private Sub ShowAllItems(ByRef d As Dictionary)

    Dim x As Variant, y As Variant, i As Long, m As String

    For Each x In d
        i = i + 1
        For Each y In d(x)
          m = d(x)(y)
          Debug.Print "Column: " & i & ", Color: " & y & ", Rows: " & Left(m, Len(m) - 2)
        Next
    Next
End Sub

结果

Selected cells: A3, B4, C2, D1, D7
Row colors:     1, 3, 4, 5, 2, 1, 6, 3, 5, 7

Column: 1, Color: 16772300,   Rows: 1, 3
Column: 1, Color: 6684672,    Rows: 2
Column: 1, Color: 16777215,   Rows: 4, 5, 6
Column: 1, Color: 192,        Rows: 7
Column: 2, Color: 16777215,   Rows: 1, 3, 6
Column: 2, Color: 16772300,   Rows: 2
Column: 2, Color: 192,        Rows: 4, 5
Column: 2, Color: 6684672,    Rows: 7
Column: 3, Color: 16777215,   Rows: 1, 3, 4, 7
Column: 3, Color: 6684672,    Rows: 2
Column: 3, Color: 16772300,   Rows: 5
Column: 3, Color: 192,        Rows: 6
Column: 4, Color: 192,        Rows: 1, 6
Column: 4, Color: 16777215,   Rows: 2
Column: 4, Color: 6684672,    Rows: 3, 5, 7
Column: 4, Color: 16772300,   Rows: 4

Sheet 1中

VBA：嵌套字典是一个很好的解决方案吗？

3 个答案: