Search code examples
excelvbacopy-paste

Copy/Paste Yellow Highlighted Cells in a new WorkSheet VBA


I'm trying to get this one done.

This macro should open a workbook (workbook names always change and there's always just one sheet to process). This works.

Set the range for the whole sheet; works fine.

And search the entire sheet for cells highlighted in yellow, and copy these cells into a new sheet... and this is where I need help!

I am really new to VBA and thats what I have so far:

Option Explicit

Sub test3()
    Dim data As Variant
    Dim rngTemp As Range
    Dim cell As Range

    '//open Workbook
    data = Application.GetOpenFilename(, , "Open Workbook")
    Workbooks.Open data


    '// set Range ( Whole Sheet)
    Set rngTemp = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
    If Not rngTemp Is Nothing Then
        Range(Cells(1, 1), rngTemp).Select
    End If

    '// Search for Yellow highlighted Cells and (if you find one)
    '// Copy Cell B1 + the 3rd Cell in the column (of the highlighted Cell) + the value highlighted Cell
    '// and paste in new Sheet
        For Each cell In rngTemp.Cells
            If rngTemp.Interior.ColorIndex = 6 Then
                cell.Select
                Selection.Copy
                Sheets.Add
                Range("A1").PasteSpecial
                Application.CutCopyMode = False
            End If
        Next
End Sub

Solution

  •  Sub test3()
        Dim wbName As string
        Dim rngTemp As Range
        Dim r As Range
        DIM TARGETSHEET AS WORKSHEET
        DIM TARGET AS RANGE
        '//open Workbook
        wbName = Application.GetOpenFilename(, , "Open Workbook")
        if  wbName = "" or wbname = "CANCEL" then exit sub
        Workbooks.Open wbname
    
    
        '// set Range ( Whole Sheet)
        Set rngTemp = Activesheet.usedrange
        SET TARGETSHEET = ACTIVEWORKBOOK.WORKSHEETS.ADD()
        SET TARGET = TARGETSHEET.RANGE("A1")  
    '// Search for Yellow highlighted Cells and (if you find one)
        '// Copy Cell B1 + the 3rd Cell in the Column (of the highlighted Cell) + the value highlighted Cell
        '// and paste in new Sheet
    
            For Each r In rngTemp
                If r.Interior.ColorIndex = 6 Then
    
    
                    TARGET = rngtemp.parent.range("B1")
                    TARGET.OFFSET(0,1) = r
                    TARGET.OFFSTE(0,2) = rngtemp.parent.cells(3,r.column)
           'I've assumed you want them across the first row
                    SET TARGET = TARGET.OFFSET(1,0)
                End If
            Next r
           End Sub