excelvbavba7

Transfer data from one sheet to another sheet based on the column header, but not for the column which has color index-RGB(237,125,49)


I transfer data from one sheet to another sheet based on the column header.

I need that if any column has color index-RGB(237,125,49), to not copy the data for that column.

Old sheet is source sheet and sheet1 is target sheet.

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
For sc = 1 To scCount
    dict(CStr(shData(1, sc))) = sdrg.Columns(sc).Value
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

Solution

  • I haven't checked your entire code, just the part where the dict variable is populated. If your goal is to skip columns where the first cell is RGB(237, 125, 49) colored, then this would be a solution

    For sc = 1 To scCount
        If sdrg.Columns(sc).Cells(1, 1).Offset(-1).Interior.Color <> RGB(237, 125, 49) Then
            dict(CStr(shData(1, sc))) = sdrg.Columns(sc).Value
        End If
    Next sc