自动筛选未返回数据后，如何处理运行时错误

Question

我有很多带有VBA宏的工作表，这些宏在自动筛选后传输数据。

当表单在自动过滤后没有数据时，宏在线上显示运行时错误1004

Workbooks("Predictology-Reports.xlsx").Sheets("FAL") _
.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues

以下是其中一个的完整宏

Sub FALAYS()
Dim arr, ws As Worksheet, lc As Long, lr As Long
arr = Array("L.FAL_19_New_Summer2", "L.FA_FAL_3", "L.FAL_19_New_Summer")
Set ws = ActiveSheet
'range from A1 to last column header and last row
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
lr = ws.Cells.Find("*", after:=ws.Range("A1"), LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

With ws.Range("A1", ws.Cells(lr, lc))
.HorizontalAlignment = xlCenter
.AutoFilter Field:=1, Criteria1:=arr, Operator:=xlFilterValues
If .Rows.Count - 1 > 0 Then
On Error Resume Next
.Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
On Error GoTo 0
Else
Exit Sub
End If
End With

Workbooks("Predictology-Reports.xlsx").Sheets("FAL") _
.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues

Application.CutCopyMode = False
End Sub

Answer 1

尝试将范围变量设置为可见行，然后在复制/粘贴之前检查是否已设置。

Sub FALAYS()
Dim arr, ws As Worksheet, lc As Long, lr As Long, rngCopy As Range
arr = Array("L.FAL_19_New_Summer2", "L.FA_FAL_3", "L.FAL_19_New_Summer")
Set ws = ActiveSheet

'range from A1 to last column header and last row
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
lr = ws.Cells.Find("*", after:=ws.Range("A1"), LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

With ws.Range("A1", ws.Cells(lr, lc))
.HorizontalAlignment = xlCenter
.AutoFilter Field:=1, Criteria1:=arr, Operator:=xlFilterValues
If .Rows.Count  > 1 Then

On Error Resume Next
Set rngCopy = .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If Not rngCopy Is Nothing Then
rngCopy.Copy
Workbooks("Predictology-Reports.xlsx").Sheets("FAL") _
.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If   'have anything to copy

End If
End With

End Sub

如果这是一个常见的任务，那么把它拉到自己的Sub:中

'given a [filtered] table rngTable, copy visible data rows as values to rngDestination
Sub CopyVisibleRows(rngTable As Range, rngDestination As Range)
Dim rngVis As Range
If rngTable.Rows.Count > 1 Then
On Error Resume Next
Set rngVis = rngTable.Offset(1, 0).Resize(rngTable.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngVis Is Nothing Then
rngVis.Copy
rngDestination.PasteSpecial xlPasteValues
End If
End If 'any source rows
End Sub

它将您的原始代码简化为类似的代码

Sub FALAYS()
Dim arr, ws As Worksheet, lc As Long, lr As Long, tbl As Range
arr = Array("L.FAL_19_New_Summer2", "L.FA_FAL_3", "L.FAL_19_New_Summer")
Set ws = ActiveSheet

'range from A1 to last column header and last row
lc = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
lr = ws.Cells.Find("*", after:=ws.Range("A1"), LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set tbl = ws.Range("A1", ws.Cells(lr, lc))
With tbl
.HorizontalAlignment = xlCenter
.AutoFilter Field:=1, Criteria1:=arr, Operator:=xlFilterValues
If .Rows.Count  > 1 Then

CopyVisibleRows  tbl, Workbooks("Predictology-Reports.xlsx").Sheets("FAL") _
.Range("A" & Rows.Count).End(xlUp).Offset(1)          

End If
End With

End Sub 

Answer 2

您可以对此代码进行许多改进，但它应该为您提供一个起点。

我将过滤后的单元格分配给一个范围，如果有单元格，则范围为"0"；什么"；。

然后直接将范围复制到工作表中(可以通过将值转移到单元格来跳过复制粘贴方法(。

提示：尽量避免On Error Resume Next，除非你知道自己在做什么，而且这是绝对必要的。

阅读注释并根据需要调整代码。

编辑：根据Tim的建议添加OERN

代码

Public Sub FALAYS()

Dim arrValues As Variant
arrValues = Array("L.FAL_19_New_Summer2", "L.FA_FAL_3", "L.FAL_19_New_Summer")

' Set the target workbook and sheet
Dim targetWorkbook As Workbook
Dim targetSheet As Worksheet
Set targetWorkbook = Workbooks("Predictology-Reports.xlsx")
Set targetSheet = targetWorkbook.Worksheets("FAL")

' Set the source sheet and range
Dim sourceSheet As Worksheet
Dim sourceRange As Range
Dim sourceColumn As Long
Dim sourceRow As Long
Set sourceSheet = ActiveSheet
'range from A1 to last column header and last row
sourceColumn = sourceSheet.Cells(1, sourceSheet.Columns.Count).End(xlToLeft).Column
sourceRow = sourceSheet.Cells.Find("*", after:=sourceSheet.Range("A1"), LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

With sourceSheet.Range("A1", sourceSheet.Cells(sourceRow, sourceColumn))
.HorizontalAlignment = xlCenter
.AutoFilter Field:=1, Criteria1:=arrValues, Operator:=xlFilterValues
If .Rows.Count - 1 > 0 Then

' Set the cells to the source range
On Error Resume Next
Set sourceRange = .Offset(1, 0).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
On Error Goto 0

' Validate if the source range has cells
If Not sourceRange Is Nothing Then
sourceRange.Copy targetSheet.Range("A" & Rows.Count).End(xlUp).Offset(1)
Else
Exit Sub
End If
End If

End With
End Sub

如果有效，请告诉我。