错误1400：没有满足标准的此类单元格

Question

以下是应用过滤器后复制数据的代码。

  Sub read_excel_file(path_to_current_work_book As String, path_to_destination_workbook As String)

Dim work_book As Object
Dim destination_workbook As Object
Dim i, m As Integer
Dim array_of_account_numbers() As Variant
Dim array_of_debit_or_credits() As Variant
Dim current_sheets As Worksheet
Dim buf_rng As Range

array_of_account_numbers = Array("1400", "1401", "1402", "1403", "1410", "1411", "1412", "1413", "1414", "1420", "1421", "1422", "1423", "1424", "1430", "1440")
array_of_debit_or_credits = Array("10", "11", "20", "21")

Application.DisplayAlerts = False
Application.Visible = True

Set work_book = Workbooks.Open(path_to_current_work_book)
Set destination_workbook = Workbooks.Open(path_to_destination_workbook)

destination_workbook.Sheets(1).Cells(1, 1).Value = "Debit(10,11)/Credit(20, 21)"
destination_workbook.Sheets(1).Cells(1, 2).Value = "Balance account number"
destination_workbook.Sheets(1).Cells(1, 3).Value = "Currency code"
destination_workbook.Sheets(1).Cells(1, 4).Value = "Resident"
destination_workbook.Sheets(1).Cells(1, 5).Value = "Amount"
destination_workbook.Sheets(1).Cells(1, 6).Value = "Date"

m = 2
For i = 1 To work_book.Worksheets.Count
    With work_book.Sheets(i)
        If (.UsedRange.Rows.Count > 1) Then
            .UsedRange.AutoFilter Field:=1, Criteria1:=array_of_debit_or_credits, Operator:=xlFilterValues
            .UsedRange.AutoFilter Field:=2, Criteria1:=array_of_account_numbers, Operator:=xlFilterValues
            m = destination_workbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).row + 1
            .AutoFilter.Range.Offset(1).Resize(.AutoFilter.Range.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy destination_workbook.Sheets(1).Range("A" & m)
        End If
    End With
Next i
work_book.Close savechanges:=False
destination_workbook.Close savechanges:=True
End Sub

它产生以下错误（当自动过滤的范围，不包括标题，为空）时：“错误1400：没有这样的单元格可以满足标准”。

.AutoFilter.Range.Offset(1).Resize(.AutoFilter.Range.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy destination_workbook.Sheets(1).Range("A" & m)

如何处理此错误？

Answer 1

将其设置为范围，然后检查范围是否为Nothing

试试这个（UNTESTED）

Dim Rng as Range

'
'~~> Rest of your code
'

On Error Resume Next
Set Rng = .AutoFilter.Range.Offset(1).Resize(.AutoFilter.Range.Rows.Count _
          - 1).SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If Not Rng Is Nothing Then
    'rng.copy... blah blah
End If

Answer 2

如果您的数据在列表范围内（我认为必须是自动过滤）并且您在每张工作表上只有一个表/列表，而不是使用work_book.Sheets(i)使用With work_book.Sheets(i).ListObjects(1)

以下是我未经检验的样本。

Sub read_excel_file(path_to_current_work_book As String, path_to_destination_workbook As String)

Dim work_book As Object
Dim destination_workbook As Object
Dim i, m As Integer
Dim array_of_account_numbers() As Variant
Dim array_of_debit_or_credits() As Variant
Dim current_sheets As Worksheet
Dim buf_rng As Range

array_of_account_numbers = Array("1400", "1401", "1402", "1403", "1410", "1411", "1412", "1413", "1414", "1420", "1421", "1422", "1423", "1424", "1430", "1440")
array_of_debit_or_credits = Array("10", "11", "20", "21")

Application.DisplayAlerts = False
Application.Visible = True

Set work_book = Workbooks.Open(path_to_current_work_book)
Set destination_workbook = Workbooks.Open(path_to_destination_workbook)

destination_workbook.Sheets(1).Cells(1, 1).Value = "Debit(10,11)/Credit(20, 21)"
destination_workbook.Sheets(1).Cells(1, 2).Value = "Balance account number"
destination_workbook.Sheets(1).Cells(1, 3).Value = "Currency code"
destination_workbook.Sheets(1).Cells(1, 4).Value = "Resident"
destination_workbook.Sheets(1).Cells(1, 5).Value = "Amount"
destination_workbook.Sheets(1).Cells(1, 6).Value = "Date"

m = 2
For i = 1 To work_book.Worksheets.Count
    With work_book.Sheets(i).ListObjects(1)
        If (.Rows.Count > 1) Then
            .AutoFilter Field:=1, Criteria1:=array_of_debit_or_credits, Operator:=xlFilterValues
            .AutoFilter Field:=2, Criteria1:=array_of_account_numbers, Operator:=xlFilterValues
            m = destination_workbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row + 1
            If .Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
                .Range.Offset(1, 0).Resize(.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1).copy destination_workbook.Sheets(1).Range("A" & m)
            End If
        End If
    End With
Next i
work_book.Close savechanges:=False
destination_workbook.Close savechanges:=True
End Sub

实际上我可能会过度思考整个事情尝试下面的代码，它只是检查过滤范围是否包含更多然后只有1个标题行，如果它确实那么它将复制，如果它没有跳过它，我相信这就是你所需要的一切。

Sub read_excel_file(path_to_current_work_book As String, path_to_destination_workbook As String)

Dim work_book As Object
Dim destination_workbook As Object
Dim i, m As Integer
Dim array_of_account_numbers() As Variant
Dim array_of_debit_or_credits() As Variant
Dim current_sheets As Worksheet
Dim buf_rng As Range

array_of_account_numbers = Array("1400", "1401", "1402", "1403", "1410", "1411", "1412", "1413", "1414", "1420", "1421", "1422", "1423", "1424", "1430", "1440")
array_of_debit_or_credits = Array("10", "11", "20", "21")

Application.DisplayAlerts = False
Application.Visible = True

Set work_book = Workbooks.Open(path_to_current_work_book)
Set destination_workbook = Workbooks.Open(path_to_destination_workbook)

destination_workbook.Sheets(1).Cells(1, 1).Value = "Debit(10,11)/Credit(20, 21)"
destination_workbook.Sheets(1).Cells(1, 2).Value = "Balance account number"
destination_workbook.Sheets(1).Cells(1, 3).Value = "Currency code"
destination_workbook.Sheets(1).Cells(1, 4).Value = "Resident"
destination_workbook.Sheets(1).Cells(1, 5).Value = "Amount"
destination_workbook.Sheets(1).Cells(1, 6).Value = "Date"

m = 2
For i = 1 To work_book.Worksheets.Count
    With work_book.Sheets(i)
        If (.UsedRange.Rows.Count > 1) Then
            .UsedRange.AutoFilter Field:=1, Criteria1:=array_of_debit_or_credits, Operator:=xlFilterValues
            .UsedRange.AutoFilter Field:=2, Criteria1:=array_of_account_numbers, Operator:=xlFilterValues
            m = destination_workbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Row + 1
            If (.AutoFilter.Range.Rows.Count > 1) Then
                .AutoFilter.Range.Offset(1).Resize(.AutoFilter.Range.Rows.Count - 1).SpecialCells(xlCellTypeVisible).copy destination_workbook.Sheets(1).Range("A" & m)
            End If
        End If
    End With
Next i
work_book.Close savechanges:=False
destination_workbook.Close savechanges:=True
End Sub

Answer 3

这是产生所需结果的工作代码。我相信，这段代码还有一些改进空间，如果有人更正，我会很感激。我要感谢user2140261和SiddharthRout给我有用的建议以及分享他们的代码。

  Sub extractInformationFromExcelFiles()
Dim path_to_folder As String
Dim path_to_final_file As String
Dim path_to_current_file As String
Dim objfso As Object
Dim objfolder As Object
Dim obj_sub_folder As Object
Dim objfile As Object
Dim final_workbook As Workbook

path_to_folder = ""
path_to_final_file = ""

Set objfso = CreateObject("Scripting.FilesystemObject")
Set objfolder = objfso.getfolder(path_to_folder)

For Each obj_sub_folder In objfolder.subfolders
    For Each objfile In obj_sub_folder.Files
        path_to_current_file = path_to_folder & obj_sub_folder.name & "\" & objfile.name
        On Error Resume Next
        readExcelFile path_to_current_file, path_to_final_file
        On Error GoTo 0
    Next objfile
Next obj_sub_folder
Set final_workbook = Workbooks.Open(path_to_final_file)
End Sub

Sub readExcelFile(path_to_current_work_book As String, path_to_destination_workbook As String)

Dim work_book As Object
Dim destination_workbook As Object
Dim i, m As Integer
Dim array_of_account_numbers() As Variant
Dim array_of_debit_or_credits() As Variant
Dim current_sheets As Worksheet
Dim buf_rng As Range

array_of_account_numbers = Array("1400", "1401", "1402", "1403", "1410", "1411", "1412", "1413", "1414", "1420", "1421", "1422", "1423", "1424", "1430", "1440")
array_of_debit_or_credits = Array("10", "11", "20", "21")

Application.DisplayAlerts = False
Application.Visible = True

Set work_book = Workbooks.Open(path_to_current_work_book)
Set destination_workbook = Workbooks.Open(path_to_destination_workbook)

destination_workbook.Sheets(1).Cells(1, 1).Value = "Debit(10,11)/Credit(20, 21)"
destination_workbook.Sheets(1).Cells(1, 2).Value = "Balance account number"
destination_workbook.Sheets(1).Cells(1, 3).Value = "Currency code"
destination_workbook.Sheets(1).Cells(1, 4).Value = "Resident"
destination_workbook.Sheets(1).Cells(1, 5).Value = "Amount"
destination_workbook.Sheets(1).Cells(1, 6).Value = "Date"
destination_workbook.Sheets(1).Cells(1, 7).Value = "Bank name under NBU classification"

m = 2
For i = 1 To work_book.Worksheets.Count
    With work_book.Sheets(i)
        If (.UsedRange.Rows.Count > 1) Then
            .UsedRange.AutoFilter Field:=1, Criteria1:=array_of_debit_or_credits, Operator:=xlFilterValues
            .UsedRange.AutoFilter Field:=2, Criteria1:=array_of_account_numbers, Operator:=xlFilterValues
            m = destination_workbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).row + 1
            If (.AutoFilter.Range.Rows.Count > 1) Then
            On Error Resume Next
                .AutoFilter.Range.Offset(1).Resize(.AutoFilter.Range.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy destination_workbook.Sheets(1).Range("A" & m)
            On Error GoTo 0
            End If
        End If
    End With
Next i
work_book.Close savechanges:=False
destination_workbook.Close savechanges:=True
End Sub