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

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:
Find coloured cells in sheet, select them and copy
Go to other file to sheet named same as source sheet
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...