如何基于列标题迁移工作表数据并排除RGB(237,125,49)颜色列？

需求：基于列标题将源工作表"Old Sheet"的数据迁移至目标工作表"Sheet1"，排除表头单元格颜色为RGB(237,125,49)的列，不复制此类列的数据。

以下是修改后的VBA代码，已实现排除逻辑：

Option Explicit

Sub Transfer()

Dim wb As Workbook: Set wb = ThisWorkbook
Dim sws As Worksheet: Set sws = wb.Worksheets("Old Sheet")

Dim sdrg As Range
Dim shData() As Variant
Dim srCount As Long
Dim scCount As Long

Dim dws As Worksheet
Dim drg As Range
Dim dhData() As Variant
Dim dcCount As Long
Dim dc As Long
Dim dHeader As String
Set dws = wb.Worksheets("Sheet1")

With sws.Range("A1").CurrentRegion
    shData = .Rows(1).Value
    srCount = .Rows.Count - 1
    scCount = .Columns.Count
    Set sdrg = .Resize(srCount).Offset(1)
End With
  
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
   
Dim sc As Long
Dim headerCell As Range
For sc = 1 To scCount
    Set headerCell = sws.Cells(1, sc)
    ' 检查表头单元格颜色是否为目标RGB值，不是才加入字典
    With headerCell.Interior
        If Not (.Color = RGB(237, 125, 49)) Then
            dict(CStr(shData(1, sc))) = sdrg.Columns(sc).Value
        End If
    End With
Next sc
   
With dws
    If Not dws Is sws Then
        With dws.Range("A1").CurrentRegion
            dhData = .Rows(1).Value
            dcCount = .Columns.Count
            Set drg = .Resize(srCount).Offset(.Rows.Count)
        End With
       
        For dc = 1 To dcCount
            dHeader = CStr(dhData(1, dc))
            If dict.Exists(dHeader) Then
               drg.Columns(dc).Value = dict(dHeader)
            End If
        Next dc
    End If
End With
End Sub

关键修改说明 #

• 在遍历源表列的循环中，新增表头颜色判断逻辑：获取当前列的表头单元格，检查其内部颜色是否为目标RGB值
• 仅当表头颜色不是RGB(237,125,49)时，才将该列数据加入字典，后续迁移流程会自动跳过被排除的列
• 保留原有的按列标题匹配迁移的核心逻辑，仅新增过滤规则

内容的提问来源于stack exchange，提问作者AG3