Макрос для копирования строк, где цвет элементов ячейки оранжевый, затем вставлять данные на новый рабочий лист

Question

У меня по большей части он работает. Кажется, я не могу пройти через блок CopyRng, чтобы установить его для каждого листа и собрать всю строку, где ячейки заполнены цветом. Set CopyRng = sh.Cells().Interior.Color = vbOrange sh.Cells().EntireRow Может ли кто-нибудь помочь?

Module1:

Function LastRow(sh As Worksheet) 
On Error Resume Next 
LastRow = sh.Cells.Find(What:="*", _ 
         After:=sh.Range("A1"), _ 
         Lookat:=xlPart, _ 
         LookIn:=xlFormulas, _ 
         SearchOrder:=xlByRows, _ 
         SearchDirection:=xlPrevious, _ 
         MatchCase:=False).Row 
On Error GoTo 0 
End Function 

Function LastCol(sh As Worksheet) 
    On Error Resume Next 
    LastCol = sh.Cells.Find(What:="*", _ 
          After:=sh.Range("A1"), _ 
          Lookat:=xlPart, _ 
          LookIn:=xlFormulas, _ 
          SearchOrder:=xlByColumns, _ 
          SearchDirection:=xlPrevious, _ 
          MatchCase:=False).Column 
    On Error GoTo 0 
End Function 

Module2:

Option Explicit 

Sub CopyRangeFromMultiWorksheets() 
Dim sh As Worksheet 
Dim DestSh As Worksheet 
Dim Last As Long 
Dim CopyRng As Range 
Dim tbl As ListObject 

Dim Cell As Range 
Dim clrOrange As Long 

With Application 
    .ScreenUpdating = False 
    .EnableEvents = False 
End With 

' Delete the summary sheet if it exists. 
Application.DisplayAlerts = False 
On Error Resume Next 
ThisWorkbook.Worksheets("SummarySheet").Delete 
On Error GoTo 0 
Application.DisplayAlerts = True 

' Add a new summary worksheet. 
Set DestSh = ThisWorkbook.Worksheets.Add 
DestSh.Name = "SummarySheet" 
Range("A1").FormulaR1C1 = "=TODAY()" 
Range("A3:G3").Font.Bold = True 
Range("A3") = "Vendor" 
Range("B3") = "Account#" 
Range("C3") = "Job/Dept" 
Range("D3") = "Cost Code/Account" 

Range("E3") = "PO" 
Range("F3") = "Bill Date" 
Range("G3") = "Bill Date2" 

clrOrange = RGB(255, 192, 0) 

' Loop through all worksheets and copy the data to the 
' summary worksheet. 
For Each sh In ThisWorkbook.Worksheets 
    For Each tbl In sh.ListObjects 

    For Each Cell In tbl.DataBodyRange 

If sh.Name <> DestSh.Name Then 

     ' Find the last row with data on the summary worksheet. 
     Last = LastRow(DestSh) 

     ' Specify the range to place the data. Select entire row where cells are orange. 

If Cell.Interior.Color = clrOrange Then 
    If CopyRng Is Nothing Then 
     Set CopyRng = Cell 
    Else 
     Set CopyRng = Union(CopyRng, Cell) 
    End If 
End If 

' This statement copies values and formats from each 
' worksheet. 

Cell.EntireRow.Copy 

     With DestSh.Cells(Last + 1, "A") 
      .PasteSpecial xlPasteValues 
      Application.CutCopyMode = False 
     End With 

    End If 
    Next 
    Next 
Next 

ExitTheSub: 

Application.GoTo DestSh.Cells(1) 

' AutoFit the column width in the summary sheet. 
DestSh.Columns.AutoFit 

With Application 
    .ScreenUpdating = True 
    .EnableEvents = True 
End With 
End Sub 

Answer 1

Вы должны проходной клетки и проверить каждый, чтобы увидеть, если они являются оранжевыми, а затем добавить их в CopyRng один за другим:

Dim Cell as Range 

For Each Cell in sh.Range("A1:A50")  'Or whatever the range is where orange cells can be 

    If Cell.Interior.Color = vbOrange Then 
     If CopyRng is Nothing then 
      Set CopyRng = Cell 
     Else 
      Set CopyRng = Union(CopyRng, Cell) 
     End If 
    EndIf 
Next 

CopyRng.Copy 
etc.