2

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

  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)

我该如何处理这个错误？

4

3 回答 3

3

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

试试这个（未经测试）

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
于 2013-09-23T13:25:13.027 回答
0

这是产生所需结果的工作代码。我相信，这段代码还有一些改进的余地，如果有人纠正它，我将不胜感激。我要感谢 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
于 2013-09-25T06:03:15.050 回答
0

如果您的数据在列表范围内（我认为必须是自动过滤）并且您在每张纸上只有一个表格/列表，然后而不是使用 With work_book.Sheets(i)useWith 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

实际上我可能想太多了，试试下面的代码，它只是检查过滤范围是否包含更多的标题行，如果它包含，那么它会复制，如果它不跳过它，我相信就是你所需要的。

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
于 2013-09-23T14:33:09.917 回答