Question

我有一个代码来复制过滤后的数据并粘贴。但是如果有空白则会抛出错误。请在此帮助我。

这是我的代码。当筛选条件存在空白时出错。请建议我需要添加什么来忽略错误并转到下一个文件

Sub GetSheets()

Dim shtname As String
Dim Path As String
Dim Filename As String
Dim myRange As Range
Dim NumRows As Long

Path = ThisWorkbook.Sheets("Filepath").Range("B2").Value
shtname = ThisWorkbook.Sheets("Filepath").Range("B3").Value
Filename = Dir(Path & "*.xls")


 Do While Filename <> ""
 Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
 Sheets(shtname).Select
 Columns("A:U").EntireColumn.Hidden = False

 Set myRange = ActiveSheet.Range("A:A")
 NumRows = Application.Count(myRange)
 r = Application.WorksheetFunction.CountA(Sheets(shtname).Range("A:A"))


 ActiveSheet.Range("$A$1:$U$1").AutoFilter Field:=19, Criteria1:="D.C"

 ActiveSheet.Range("A2:U" & NumRows).SpecialCells(xlCellTypeVisible).Select
 Selection.Copy

 Windows("Combined - Dc Pharmacy chargeback.xlsm").Activate

 Sheets("Sheet1").Select
 Range("A1").Select
 Selection.End(xlDown).Select
 ActiveCell.Offset(1, 0).Select
 ActiveSheet.Paste
 Application.CutCopyMode = False
 Application.DisplayAlerts = False
 Workbooks(Filename).Close
 Filename = Dir()
 Loop
End Sub

请在此建议

Answer 1

没有单元格可见时会发生错误。您可以使用On Error Resume Next捕获此错误，如下所示。

Private Sub CopyFiltered()

    Dim Rng As Range
    Dim Rl As Long                          ' last row

    Application.ScreenUpdating = False
    With ActiveSheet
        Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set Rng = Range(.Cells(2, "A"), .Cells(Rl, "A"))

        .Range("$A$1:$U$1").AutoFilter Field:=19, Criteria1:="D.C"

        On Error Resume Next
        Set Rng = Rng.SpecialCells(xlCellTypeVisible)
        If Err = 0 Then
            Rng.Copy
            ' Change this address as required
            Worksheets("Manager").Cells(20, 3).Resize(Rng.Cells.Count, 1).PasteSpecial xlValues
        End If

        On Error GoTo 0
        .ShowAllData
        Rng.AutoFilter
    End With

    With Application
        .ScreenUpdating = True
        .CutCopyMode = False
    End With
End Sub

Answer 2

Sub GetSheets()

Dim shtname As String
Dim Path As String
Dim Filename As String
Dim myRange As Range
Dim NumRows As Long

Path = ThisWorkbook.Sheets("Filepath").Range("B2").Value
shtname = ThisWorkbook.Sheets("Filepath").Range("B3").Value
Filename = Dir(Path & "*.xls")

On Error Resume Next

  Do While Filename <> ""
  Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
 Sheets(shtname).Select
 Columns("A:U").EntireColumn.Hidden = False


  Set myRange = ActiveSheet.Range("A:A")
  NumRows = Application.Count(myRange)
r = Application.WorksheetFunction.CountA(Sheets(shtname).Range("A:A"))




ActiveSheet.Range("$A$1:$U$1").AutoFilter Field:=19, Criteria1:="D.C"
ActiveSheet.Range("A2:U" & NumRows).SpecialCells(xlCellTypeVisible).Select



x = ActiveSheet.Range("A65000").End(xlUp).Row

If x > 1 Then

     Selection.Copy

     Windows("Combined - Dc Pharmacy chargeback.xlsm").Activate

     Sheets("Sheet1").Select
     Range("A1").Select
     Selection.End(xlDown).Select
     ActiveCell.Offset(1, 0).Select
     ActiveSheet.Paste

   End If
     Application.CutCopyMode = False
     Application.DisplayAlerts = False
     Workbooks(Filename).Close

     Filename = Dir()



Loop

End Sub

如果自动过滤器没有将数据移动到下一个文件

2 个答案: