Question

我目前正在尝试扫描D＆amp; 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

在sh.Activate

之后添加If sh.Name <> DestSh.Name Then

另请考虑'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中的值是否符合条件。如果不希望这样，您可能希望切换行或设置更多标准以使用。看看这是否有帮助！：）

Excel VBA搜索多个工作表＆amp;将所选行粘贴到摘要工作表

2 个答案: