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列中的值是否都符合条件，您可能会得到重复的值。如果这不是所需的，您可能想要剪切行或设置更多的条件来使用。看看这是否有帮助！:)