копирование выделенных ячеек в отдельный лист

macros.vba

Sub SelectActualUsedRange()
  Dim FirstCell As Range, LastCell As Range
  Set LastCell = Cells(Cells.Find(What:="*", SearchOrder:=xlRows, _
      SearchDirection:=xlPrevious, LookIn:=xlValues).row, _
      Cells.Find(What:="*", SearchOrder:=xlByColumns, _
      SearchDirection:=xlPrevious, LookIn:=xlValues).Column)
  Set FirstCell = Cells(Cells.Find(What:="*", After:=LastCell, SearchOrder:=xlRows, _
      SearchDirection:=xlNext, LookIn:=xlValues).row, _
      Cells.Find(What:="*", After:=LastCell, SearchOrder:=xlByColumns, _
      SearchDirection:=xlNext, LookIn:=xlValues).Column)
  Range(FirstCell, LastCell).Select
End Sub

Sub SelectColoredCells(sheet As Worksheet, color As String)
    Dim rCell As Range
    Dim lColor As Long
    Dim rColored As Range
    Dim mySel As Range
    Dim col As Integer
    Dim row As Integer

    col = 1
    row = 1
    'Select the color by name (8 possible)
    'vbBlack, vbBlue, vbGreen, vbCyan,
    'vbRed, vbMagenta, vbYellow, vbWhite
    lColor = color

    'If you prefer, you can use the RGB function
    'to specify a color
    'lColor = RGB(0, 0, 255)
    Sheets("sh1").Activate
    Call SelectActualUsedRange


    Set rColored = Nothing
    For Each rCell In Selection
        If rCell.Interior.color = lColor Then
            If rColored Is Nothing Then
                Set rColored = rCell
            Else
                Set rColored = Union(rColored, rCell)
                
            End If
            
            rCell.Copy sheet.Range(Cells(row, col).Address)

            col = col + 1
            If col Mod 4 = 0 Then
                row = row + 1
                col = 1
            End If
                        
        End If
    Next
    If rColored Is Nothing Then
        MsgBox "No cells match the color"
    Else
        rColored.Select
        MsgBox "Selected cells match the color:" & _
            vbCrLf & rColored.Address
    End If
    Set rCell = Nothing
    Set rColored = Nothing

    sheet.Activate

End Sub


Sub Printsheet()
    Dim wsA As Worksheet
    Dim newWs As Worksheet
    Dim mainWB As Workbook
    
    Set mainWB = ActiveWorkbook
    Set wsA = Sheets("sh1")
    
    Dim Newname As String
    Newname = "selected"
    Sheets.Add _
        After:=mainWB.Sheets(mainWB.Sheets.Count), _
        Type:=xlWorksheet
    ActiveSheet.Name = Newname & mainWB.Sheets.Count
    Set newWs = ActiveSheet
    
    Dim color As String
    color = wsA.Range("A1").Interior.color
    wsA.Activate

    ' color 16777215 = no color

    If Not color = 16777215 Then

        MsgBox "Has Color " & color
        Call SelectColoredCells(newWs, color)

    Else
        MsgBox "A1 no colored"
    End If
        
End Sub