我正在使用下面的宏打开文件，将列D过滤到“Pps”并将可见数据复制到目标工作表，之后我清除过滤器（编码到目前为止工作）然后再次过滤列D， “的Pkt”。但是，过滤结果返回空了..任何想法出了什么问题？提前谢谢！
Private Sub Generate_cmb_Click()
Dim SourceSQ01Wb As Workbook, DestWb As Workbook
Dim SourceSQ01Ws As Worksheet, DestPpsWs As Worksheet, DestPktWs As Worksheet
Dim SourceSQ01FilterRng As Range, SourceSQ01CopyRng As Range
Application.ScreenUpdating = False
Set SourceSQ01Wb = Workbooks.Open("D:\\SQ01.xlsx", , True) 'Readonly = True
Set SourceSQ01Ws = SourceSQ01Wb.Worksheets("Sheet1")
SourceSQ01Ws.Range("A:E,G:G,I:N,P:S,U:X,AD:AE,AH:AI").EntireColumn.Delete
Set SourceSQ01FilterRng = SourceSQ01Ws.Range("A1:K" & LastRow(SourceSQ01Ws))
Set DestWb = ThisWorkbook
Set DestPpsWs = DestWb.Worksheets("Packet Plus")
Set DestPktWs = DestWb.Worksheets("Packet")
'---------------- FOR PPS ----------------
'Filter and set the filter field & criteria
SourceSQ01FilterRng.AutoFilter Field:=4, Criteria1:="=Pps"
With SourceSQ01FilterRng.Parent.AutoFilter.Range
On Error Resume Next
' Set SourceSQ01CopyRng to the visible cells in SourceSQ01FilterRng without the header row
Set SourceSQ01CopyRng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not SourceSQ01CopyRng Is Nothing Then
'Copy and paste the cells into DestPpsWs below the existing data
SourceSQ01CopyRng.Interior.Color = xlNone
SourceSQ01CopyRng.Copy
With DestPpsWs.Range("A" & LastRow(DestPpsWs) + 1)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
End With
Application.Goto DestPpsWs.Range("A1")
'---------------- FOR PKT ----------------
'Clear filer
SourceSQ01FilterRng.Parent.AutoFilterMode = False
'Filter and set the filter field & criteria
SourceSQ01FilterRng.AutoFilter Field:=4, Criteria1:="=Pkt"
With SourceSQ01FilterRng.Parent.AutoFilter.Range
On Error Resume Next
' Set SourceSQ01CopyRng to the visible cells in SourceSQ01FilterRng without the header row
Set SourceSQ01CopyRng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not SourceSQ01CopyRng Is Nothing Then
'Copy and paste the cells into DestPktWs below the existing data
SourceSQ01CopyRng.Interior.Color = xlNone
SourceSQ01CopyRng.Copy
With DestPpsWs.Range("A" & LastRow(DestPktWs) + 1)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
End If
End With
Application.Goto DestPktWs.Range("A1")
'--------------------------------
'Close SourceSQ01Wb without saving changes
'SourceSQ01Wb.Close (False)
Application.ScreenUpdating = True
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
答案 0 :(得分：0)
第二个（PKT）粘贴过程粘贴到 DestPpsWs 工作表，而不是 DestPktWs 工作表。您的结果最终会出现在 DestPpsWs 工作表上由LastRow确定的 DestPpsWs 工作表上。
应该是：
With DestPktWs.Range("A" & LastRow(DestPktWs) + 1)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
End With
我在模拟中的第83行。你的可能会略有不同。
避免复制＆amp;粘贴这样的错误，我将遍历一个数组，该数组包含重复进程的各个参数。这是一个使用循环的快速重写。
Public Sub Generate_cmb_Click_Loops()
Dim v As Long, vDestinations() As Variant
Dim SourceSQ01Wb As Workbook, DestWb As Workbook
Dim SourceSQ01Ws As Worksheet
Dim SourceSQ01FilterRng As Range, SourceSQ01CopyRng As Range
vDestinations = Array("Packet Plus", "Pps", _
"Packet", "Pkt")
'turn back on after debugging
'Application.ScreenUpdating = False
Set SourceSQ01Wb = Workbooks.Open("D:\\SQ01.xlsx", ReadOnly:=True)
Set SourceSQ01Ws = SourceSQ01Wb.Worksheets("Sheet1")
SourceSQ01Ws.Range("A:E,G:G,I:N,P:S,U:X,AD:AE,AH:AI").EntireColumn.Delete
'currentRegion does not depend on visible cells like .Find does
Set SourceSQ01FilterRng = SourceSQ01Ws.Range("A1").CurrentRegion
Set DestWb = ThisWorkbook
'---------------- FOR PPS/PKT ----------------
With SourceSQ01FilterRng
With .Resize(.Rows.Count, 11) '<~~ A:K
For v = LBound(vDestinations) To UBound(vDestinations) Step 2
'check for existing AutoFilter; turn off if found
If .Parent.AutoFilterMode Then .Parent.AutoFilterMode = False
'Filter and set the filter field & criteria
.AutoFilter Field:=4, Criteria1:=vDestinations(v + 1)
' Set SourceSQ01CopyRng to the visible cells in SourceSQ01FilterRng without the header row
On Error Resume Next
'note: resize before offset otherwise (very rarely) it can crash
Set SourceSQ01CopyRng = .Resize(.Rows.Count - 1, .Columns.Count).Offset(1, 0) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not SourceSQ01CopyRng Is Nothing Then
'Copy and paste the cells into DestPpsWs below the existing data
SourceSQ01CopyRng.Interior.Color = xlNone
SourceSQ01CopyRng.Copy
With Worksheets(vDestinations(v)).Range("A" & _
LastRow(Worksheets(vDestinations(v))) + 1)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
Application.Goto .Parent.Range("A1")
End With
End If
Next v
End With
'check for leftover AutoFilter; turn it off
If .Parent.AutoFilterMode Then .Parent.AutoFilterMode = False
End With
'--------------------------------
'Close SourceSQ01Wb without saving changes
'SourceSQ01Wb.Close (False)
Application.ScreenUpdating = True
End Sub
我删除了一些冗余代码，并使用Range.CurrentRegion property来设置过滤器范围。 .CurrentRegion不依赖于Range.Find method之类的可见行，因此如果在源工作表上使用过滤器启动过程并不重要。