Excel VBA搜索多個工作表並將選定的行粘貼到摘要工作表

Question

我目前正在嘗試掃描多個工作表中的D和K列（數量可能有所不同）。 如果D列中的值為9或10，或者K列中的值> 100，我想將整行復制到摘要表中。 它創建摘要工作表，但不復制任何行。 這是我到目前為止的內容：

 Option Explicit

Sub AppendDataAfterLastColumn()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range
Dim SearchRng As Range
Dim SearchRng1 As Range
Dim rngCell As Range
Dim lastrow As String

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

' Delete the summary worksheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Action Items").Delete
On Error GoTo 0
Application.DisplayAlerts = True

' Add a worksheet with the name "Action Items"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Action Items"
Sheets("Action Items").Move Before:=Sheets(3)

Sheets(4).Select
Range("A1:U3").Select
Selection.Copy
Sheets("Action Items").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
ActiveSheet.Paste
Range("a1") = "PFMEA Action Items"

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

        If sh.Name <> DestSh.Name Then

            Set SearchRng = ActiveSheet.Range("D:D, K:K")

            ' Find the last row with data on the summary
            ' worksheet.
            Last = Worksheets("Action Items").UsedRange.Rows.Count

                For Each rngCell In SearchRng.Cells

                    If rngCell.Value <> "" Then

                        If rngCell.Value = "9" Or "10" Then
                        'select the entire row
                            rngCell.EntireRow.Select
                            MsgBox Selection.Address(False, False)
                            Selection.Copy

                            ' This statement copies values, formats, and the column width.

                            lastrow = DestSh.Cells(Rows.Count, "A").End(xlUp).Row + 1
                            DestSh.Cells(lastrow, "A").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                                SkipBlanks:=False, Transpose:=False

                        ElseIf rngCell.Value > 100 Then

                            'select the entire row
                            rngCell.EntireRow.Select
                            Selection.Copy

                            ' This statement copies values, formats, and the column width.
                            lastrow = DestSh.Cells(Rows.Count, "A").End(xlUp).Row + 1
                            DestSh.Cells(lastrow, "A").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
                                SkipBlanks:=False, Transpose:=False

                        End If

                    End If

                Next rngCell

        End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

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

謝謝您的幫助！

Answer 1

If sh.Name <> DestSh.Name Then添加sh.Activate

還考慮“ PartyHatPanda”給出的評論

Answer 2

我認為這里的問題出在您粘貼特殊代碼中，您正在告訴它粘貼列寬。 我復制了代碼DestSh.Cells(lastrow, "A").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ，然后將其更改為DestSh.Cells(lastrow, "A").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 。 對我來說，它復制行和值。 編寫方式可能會重復，具體取決於d列和k列中的值是否符合標准。 如果不希望這樣做，則可能要減少行數或設置更多可使用的條件。 看看是否有幫助！ :)