Question

我大部分都在工作。我似乎无法通过CopyRng块为每个工作表设置它并收集单元格填充颜色的整行。 Set CopyRng = sh.Cells().Interior.Color = vbOrange sh.Cells().EntireRow任何人都可以提供帮助吗？

模块1：

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

单词数：

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.

用于复制单元格内部颜色为橙色的行的宏，然后将数据粘贴到新工作表

1 个答案: