VBA - copy data from range and paste in same range in other file

Question

I'm trying to find a solution for macro described below in steps - it should copy data from range in one file and then paste it in other file in same range as original data:

1. Find coloured cells in sheet, select them and copy
2. Go to other file to sheet named same as source sheet
3. Paste data in same ranges as in source file (e.g. if data was copied from range A4:B20, A22:B24 and E4:G20 [selection will always contain union of ranges like this] I want to use same ranges in destination to paste data)

In below code I get error "Application-defined or object-defined error" and part of code "With ActiveSheet.Range(SelectedRng)" highlighted in yellow.

Could you please help me find a solution for this?

Sub SelectCellsWithColorIndex()

    Const rgAddress As String = "A1:AZ300"
    Const cIndex As Long = 37
    
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim rg As Range: Set rg = ws.Range(rgAddress)
    Dim sh_name As String
    Dim crg As Range
    Dim cell As Range
    Dim SelectedRng As Range
    
    
Application.ScreenUpdating = False
    
    For Each cell In rg.Cells
        If cell.Interior.ColorIndex = cIndex Then
            If crg Is Nothing Then
                Set crg = cell
            Else
                Set crg = Union(crg, cell)
            End If
        End If
    Next cell
    
    If crg Is Nothing Then
        MsgBox "No coloured cells in range.", vbExclamation
    Else
        crg.Select
    End If

Set SelectedRng = ActiveSheet.Range(Selection.Address)
SelectedRng.Copy
    
sh_name = ActiveSheet.Name

Workbooks("Workbook2.xlsx").Activate
Worksheets(sh_name).Activate

With ActiveSheet.Range(SelectedRng)
.PasteSpecial xlPasteValues
End With
    
Application.ScreenUpdating = True
    
End Sub

Answer 1

Please, try the next way. It uses Find with SearchFormat parameter and should be much faster than iteration between each cell in the range. Then, a discontinuous (Union) range cannot be copied at once. In order to also be fast, an iteration between the discontinuous range areas are necessary and clipboard should not be used. Selecting, activating only consumes Excel resources, not bringing any benefit, too:

Sub SelectCellsWithColorIndex()
    Const rgAddress As String = "A1:AZ300"
    Const cIndex As Long = 37
    
    Dim ws As Worksheet: Set ws = ActiveSheet
    Dim ws2 As Worksheet: Set ws2 = Workbooks("Workbook2.xlsx").Worksheets(ws.name) 'it must exist!
    
    Dim rg As Range: Set rg = ws.Range(rgAddress)

    Dim crg As Range, blueCell As Range, firstAddress As String, A As Range

    
    'Sets or returns the search criteria for the type of cell formats to find:
    With Application.FindFormat
          .Clear
          .Interior.ColorIndex = cIndex
          .Locked = True
    End With
    
    Set blueCell = rg.Find(what:=vbNullString, SearchFormat:=True)

    If Not blueCell Is Nothing Then
          firstAddress = blueCell.Address
            Do
                If crg Is Nothing Then Set crg = blueCell Else Set crg = Union(crg, blueCell)
                Set blueCell = rg.Find(what:=vbNullString, After:=blueCell, SearchFormat:=True)
            Loop While blueCell.Address <> firstAddress
    Else
        MsgBox "no cell with (that) blue color found", vbInformation, "No blue cells...": Exit Sub
    End If
    
    For Each A In crg.Areas
        ws2.Range(A.Address).Value = A.Value
   Next A
End Sub

Please, send some feedback after testing it.

Is the Union range is huge, Application.ScreenUpdating = False and Application.Calculation = xlCalculationManual at the beginning of copying loop followed by Application.ScreenUpdating = True and Application.Calculation = xlCalculationAutomatic after, will help a litle. Otherwise, for a reasonable number of cells it will be fast enough without any optimization...