Search code examples
excelvba

VBA code needed to select cells based on color and paste copied values into selected cells


I've recorded a macro of the steps needed to achieve the results I am looking for out of this macro. My issue is that the recorded steps are static. I need to have some steps of the code be able to be variable based on the cell's color.

Sub NewJobDefaultRowValues()
'
' NewJobDefaultRowValues Macro
' Select and Copy the Default Row values
    Sheets("Sheet1").Select
    Range("A226:AL226").Select
    Selection.Copy

' Select the Sheet that the copied cells are to be pasted in
    Sheets("Sheet2").Select

' Filter the cells by color in Column A of Sheet 2 to only show 
'    Cells Colored YELLOW (These cells are colored using Conditional Formatting)
    activeSheet.Range("$A$2:$AL$532").AutoFilter Field:=1, Criteria1:=RGB(255, _
        255, 0), Operator:=xlFilterCellColor

'** THIS IS THE STEPS NEEDING TO BE VARIABLE. 
'   These values will change depending on the inserted rows.
'** Select all of the filtered cells.
    Range("A11:A19").Select

' Paste the copied cells from Sheet1 into the filtered cells of Sheet2
    activeSheet.Paste

' Remove the filter from Sheet2
    activeSheet.Range("$A$2:$AL$532").AutoFilter Field:=1

' Sheet 3 has cell values formulated to equal corresponding cells 
'   of Sheet2. These are the steps taken to realign the row 
'   numbers in the formulas
    Sheets("Sheet3").Select
    Range("A3:G3").Select
    Application.CutCopyMode = False
    Selection.AutoFill Destination:=Range("A3:G537")
    Range("A3:G537").Select
End Sub

After further researching and acquiring grey hairs, I believe this macro below will be easier to modify/add to.

What would be the replacement code for

ws.Activate
Rows(activeRow & ":" & activeRow + iCountRows - 1).Insert Shift:=xlDown

that would copy row 226 from Sheet3 and insert into the selected row? Also, I will need to keep the last steps of the first macro shown.

Sub insertRowSheets()

    ' Disable Excel properties before macro runs
    With Application
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
        ' Declare object variables
        Dim ws As Worksheet, iCountRows As Integer
        Dim activeSheet As Worksheet, activeRow As Long
        Dim startSheet As String
        Dim sheetArray As Variant
        
         ' select worksheets in active workbook to insert rows
                Sheets(Array("Planner Tracker", "Plan Mhrs")).Select
        
            ' State activeRow
            activeRow = ActiveCell.Row
            
                ' Save initial active sheet selection
                startSheet = ThisWorkbook.activeSheet.Name
                
                'capture the selected sheets
                Set sheetArray = ActiveWindow.SelectedSheets
                
                    ' Trigger input message to appear - in terms of how many rows to insert
                    iCountRows = Application.InputBox(Prompt:="How Many Rows Do You Want To Insert, Starting With Row " _
                    & activeRow & "?", Type:=1)
                    
                        ' Error handling - end the macro if a zero, negative integer or non-interger value is entered
                        If iCountRows = False Or iCountRows <= 0 Then End
                            
                            ' Loop Through the worksheets selected in active workbook
                            For Each ws In sheetArray
                            
                            ws.Activate
                            Rows(activeRow & ":" & activeRow + iCountRows - 1).Insert Shift:=xlDown
                                
                            Next ws
                            
            ' Move Cursor back to initial worksheet and cell selected
            Worksheets(startSheet).Select True
            ActiveCell.Select
            
    ' Re-enable Excel properties once macro is complete
    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
        
End Sub

Solution

  • Non-macro recorder version:

    Sub NewJobDefaultRowValues()
        
        Const LR As Long = 532   'last row of data
        
        Dim c As Range, data As Range, wb As Workbook
        
        Set wb = ThisWorkbook 'don't rely on the implicit ActiveWorkbook
        Application.ScreenUpdating = False 'faster
        
        Set data = wb.Worksheets("Sheet1").Range("A226:AL226") '<< be specific
        'copy range `data` to any colored cells
        For Each c In wb.Worksheets("Sheet2").Range("A2:A" & LR).Cells
            'If color is from Conditional Formatting, must use `DisplayFormat`
            If c.DisplayFormat.Interior.Color = RGB(255, 255, 0) Then 'check color
                data.Copy c
            End If
        Next c
        
        With wb.Worksheets("Sheet3").Range("A3:G" & LR)
            .Rows(1).AutoFill Destination:=.Cells 'fill first row down
            .Parent.Select '<< select the sheet first
            .Select
        End With
    End Sub
    

    Unless you have a lot of rows to process, I find a simple loop is easier to manage than using autofilter and SpecialCells(xlCellTypeVisible).