我目前正在尝试在多个工作表中扫描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
谢谢您的帮助！
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中的值是否符合条件 . 如果不希望这样，您可能希望切换行或设置更多标准以使用 . 看看这是否有帮助！ :)在
If sh.Name <> DestSh.Name Then之后添加sh.Activate还要考虑'PartyHatPanda'给出的评论