Question

我的代码遍历Excel文件的大目录并执行任务（过滤文件并将结果放入活动工作簿中的新工作表中）。 VBA会跳过无法加载的文件（文件可能无法读取）：

Sub Ladiesman191()
'includes filling down

Dim wb As Workbook, fileNames As Object, errCheck As Boolean
    Dim ws As Worksheet, wks As Worksheet, wksSummary As Worksheet
    Dim y As Range, intRow As Long, i As Integer
    Dim r As Range, lr As Long, myrg As Range, z As Range
    Dim boolWritten As Boolean, lngNextRow As Long
    Dim intColNode As Integer, intColScenario As Integer
    Dim intColNext As Integer, lngStartRow As Long

    Dim lngLastNode As Long, lngLastScen As Long

     ' Turn off screen updating and automatic calculation
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

     ' Create a new worksheet, if required
    On Error Resume Next
    Set wksSummary = ActiveWorkbook.Worksheets("Unique data")
    On Error GoTo 0
    If wksSummary Is Nothing Then
        Set wksSummary = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
        wksSummary.Name = "Unique data"
    End If

     ' Set the initial output range, and assign column headers
    With wksSummary
        Set y = .Cells(.Rows.Count, 3).End(xlUp).Offset(1, 0)
        Set r = y.Offset(0, 1)
        Set z = y.Offset(0, -2)
        lngStartRow = y.Row
        .Range("A1:D1").Value = Array("File Name", "Sheet Name", "Node Name", "Scenario Name")
    End With

'get user input for files to search
Set fileNames = CreateObject("Scripting.Dictionary")
errCheck = UserInput.FileDialogDictionary(fileNames)
If errCheck Then
   Exit Sub
End If
'''
For Each Key In fileNames 'loop through the dictionary




On Error Resume Next
Set wb = Workbooks.Open(fileNames(Key))
If Err.Number <> 0 Then
    Set wb = Nothing    ' or set a boolean error flag
End If
On Error GoTo 0    ' or your custom error handler

If wb Is Nothing Then
    Debug.Print "Error when loading " & fileNames(Key)
Else
    Debug.Print "Successfully loaded " & fileNames(Key)
    wb.Application.Visible = False 'make it not visible
    ' more working with wb



 ' Check each sheet in turn
    For Each ws In ActiveWorkbook.Worksheets
        With ws
             ' Only action the sheet if it's not the 'Unique data' sheet
            If .Name <> wksSummary.Name Then
                boolWritten = False

                 ' Find the Scenario column
                intColScenario = 0
                On Error Resume Next
                intColScenario = WorksheetFunction.Match("scenarioName", .Rows(1), 0)
                On Error GoTo 0

                If intColScenario > 0 Then
                     ' Only action if there is data in column E
                    If Application.WorksheetFunction.CountA(.Columns(intColScenario)) > 1 Then
                         ' Find the next free column, in which the extract formula will be placed
                        intColNext = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1

                         ' Assign formulas to the next free column to identify the scenario name to the left of the first _ character
                        .Cells(1, intColNext).Value = "Test"
                        lr = .Cells(.Rows.Count, intColScenario).End(xlUp).Row
                        Set myrg = .Range(.Cells(2, intColNext), .Cells(lr, intColNext))
                        With myrg
                            .ClearContents
                            .FormulaR1C1 = "=IFERROR(LEFT(RC" & intColScenario & ",FIND(INDEX({""+"",""-"",""_"",""$"",""%""},1,MATCH(1,--(ISNUMBER(FIND({""+"",""-"",""_"",""$"",""%""},RC" & _
                            intColScenario & "))),0)), RC" & intColScenario & ")-1), RC" & intColScenario & ")"
                            .Value = .Value
                        End With

                         ' Copy unique values from the formula column to the 'Unique data' sheet, and write sheet & file details
                        .Range(.Cells(1, intColNext), .Cells(lr, intColNext)).AdvancedFilter xlFilterCopy, , r, True
                        r.Offset(0, -2).Value = ws.Name
                        r.Offset(0, -3).Value = ws.Parent.Name

                         ' Clear the interim results
                        .Range(.Cells(1, intColNext), .Cells(lr, intColNext)).ClearContents

                         ' Delete the column header copied to the list
                        r.Delete Shift:=xlUp
                        boolWritten = True
                    End If
                End If

                 ' Find the Node column
                intColNode = 0
                On Error Resume Next
                intColNode = WorksheetFunction.Match("node", .Rows(1), 0)
                On Error GoTo 0

                If intColNode > 0 Then
                     ' Only action if there is data in column A
                    If Application.WorksheetFunction.CountA(.Columns(intColNode)) > 1 Then
                        lr = .Cells(.Rows.Count, intColNode).End(xlUp).Row

                         ' Copy unique values from column A to the 'Unique data' sheet, and write sheet & file details (if not already written)
                        .Range(.Cells(1, intColNode), .Cells(lr, intColNode)).AdvancedFilter xlFilterCopy, , y, True
                        If Not boolWritten Then
                            y.Offset(0, -1).Value = ws.Name
                            y.Offset(0, -2).Value = ws.Parent.Name
                        End If

                         ' Delete the column header copied to the list
                        y.Delete Shift:=xlUp
                    End If
                End If

         ' Identify the next row, based on the most rows used in columns C & D
                lngLastNode = wksSummary.Cells(wksSummary.Rows.Count, 3).End(xlUp).Row
                lngLastScen = wksSummary.Cells(wksSummary.Rows.Count, 4).End(xlUp).Row
                lngNextRow = WorksheetFunction.Max(lngLastNode, lngLastScen) + 1
                If (lngNextRow - lngStartRow) > 1 Then



                     ' Fill down the workbook and sheet names
                    z.Resize(lngNextRow - lngStartRow, 2).FillDown
                    If (lngNextRow - lngLastNode) > 1 Then
                         ' Fill down the last Node value
                        wksSummary.Range(wksSummary.Cells(lngLastNode, 3), wksSummary.Cells(lngNextRow - 1, 3)).FillDown
                    End If
                    If (lngNextRow - lngLastScen) > 1 Then
                         ' Fill down the last Scenario value
                        wksSummary.Range(wksSummary.Cells(lngLastScen, 4), wksSummary.Cells(lngNextRow - 1, 4)).FillDown
                    End If
                End If



                Set y = wksSummary.Cells(lngNextRow, 3)
                Set r = y.Offset(0, 1)
                Set z = y.Offset(0, -2)
                lngStartRow = y.Row
            End If
        End With
    Next ws
wb.Close savechanges:=False 'close the workbook do not save
Set wb = Nothing 'release the object
End If

Next 'End of the fileNames loop
Set fileNames = Nothing

 ' Autofit column widths of the report
wksSummary.Range("A1:D1").EntireColumn.AutoFit

' Reset system settings

With Application
   .Calculation = xlCalculationAutomatic
   .ScreenUpdating = True
   .Visible = True
End With
End Sub

是否有代码可以跳过文件并将文件名跳过活动工作簿中的新工作表？

EDIT ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~

使用Katz Fix，还添加了＆＃34; Skipped＆＃34;手动到我的工作簿：

Sub Katz()
'includes filling down

Dim wb As Workbook, fileNames As Object, errCheck As Boolean
    Dim ws As Worksheet, wks As Worksheet, wksSummary As Worksheet
    Dim y As Range, intRow As Long, i As Integer
    Dim r As Range, lr As Long, myrg As Range, z As Range
    Dim boolWritten As Boolean, lngNextRow As Long
    Dim intColNode As Integer, intColScenario As Integer
    Dim intColNext As Integer, lngStartRow As Long

    Dim lngLastNode As Long, lngLastScen As Long


    'Compile skipped files
    Dim wksSkipped As Worksheet
    Set wksSkipped = ThisWorkbook.Worksheets("Skipped")

     ' Turn off screen updating and automatic calculation
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

     ' Create a new worksheet, if required
    On Error Resume Next
    Set wksSummary = ActiveWorkbook.Worksheets("Unique data")
    On Error GoTo 0
    If wksSummary Is Nothing Then
        Set wksSummary = ActiveWorkbook.Worksheets.Add(After:=ActiveWorkbook.Worksheets(ActiveWorkbook.Worksheets.Count))
        wksSummary.Name = "Unique data"
    End If

     ' Set the initial output range, and assign column headers
    With wksSummary
        Set y = .Cells(.Rows.Count, 3).End(xlUp).Offset(1, 0)
        Set r = y.Offset(0, 1)
        Set z = y.Offset(0, -2)
        lngStartRow = y.Row
        .Range("A1:D1").Value = Array("File Name", "Sheet Name", "Node Name", "Scenario Name")
    End With

'get user input for files to search
Set fileNames = CreateObject("Scripting.Dictionary")
errCheck = UserInput.FileDialogDictionary(fileNames)
If errCheck Then
   Exit Sub
End If
'''
For Each Key In fileNames 'loop through the dictionary




On Error Resume Next
Set wb = Workbooks.Open(fileNames(Key))
If Err.Number <> 0 Then
    Set wb = Nothing    ' or set a boolean error flag
End If
On Error GoTo 0    ' or your custom error handler

If wb Is Nothing Then
wksSkipped.Cells(wksSkipped.Cells(wksSkipped.Rows.Count, "A").End(xlUp).Row + 1, 1) = wb.Name
Else
    Debug.Print "Successfully loaded " & fileNames(Key)
    wb.Application.Visible = False 'make it not visible
    ' more working with wb



 ' Check each sheet in turn
    For Each ws In ActiveWorkbook.Worksheets
        With ws
             ' Only action the sheet if it's not the 'Unique data' sheet
            If .Name <> wksSummary.Name Then
                boolWritten = False

                 ' Find the Scenario column
                intColScenario = 0
                On Error Resume Next
                intColScenario = WorksheetFunction.Match("scenarioName", .Rows(1), 0)
                On Error GoTo 0

                If intColScenario > 0 Then
                     ' Only action if there is data in column E
                    If Application.WorksheetFunction.CountA(.Columns(intColScenario)) > 1 Then
                         ' Find the next free column, in which the extract formula will be placed
                        intColNext = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1

                         ' Assign formulas to the next free column to identify the scenario name to the left of the first _ character
                        .Cells(1, intColNext).Value = "Test"
                        lr = .Cells(.Rows.Count, intColScenario).End(xlUp).Row
                        Set myrg = .Range(.Cells(2, intColNext), .Cells(lr, intColNext))
                        With myrg
                            .ClearContents
                            .FormulaR1C1 = "=IFERROR(LEFT(RC" & intColScenario & ",FIND(INDEX({""+"",""-"",""_"",""$"",""%""},1,MATCH(1,--(ISNUMBER(FIND({""+"",""-"",""_"",""$"",""%""},RC" & _
                            intColScenario & "))),0)), RC" & intColScenario & ")-1), RC" & intColScenario & ")"
                            .Value = .Value
                        End With

                         ' Copy unique values from the formula column to the 'Unique data' sheet, and write sheet & file details
                        .Range(.Cells(1, intColNext), .Cells(lr, intColNext)).AdvancedFilter xlFilterCopy, , r, True
                        r.Offset(0, -2).Value = ws.Name
                        r.Offset(0, -3).Value = ws.Parent.Name

                         ' Clear the interim results
                        .Range(.Cells(1, intColNext), .Cells(lr, intColNext)).ClearContents

                         ' Delete the column header copied to the list
                        r.Delete Shift:=xlUp
                        boolWritten = True
                    End If
                End If

                 ' Find the Node column
                intColNode = 0
                On Error Resume Next
                intColNode = WorksheetFunction.Match("node", .Rows(1), 0)
                On Error GoTo 0

                If intColNode > 0 Then
                     ' Only action if there is data in column A
                    If Application.WorksheetFunction.CountA(.Columns(intColNode)) > 1 Then
                        lr = .Cells(.Rows.Count, intColNode).End(xlUp).Row

                         ' Copy unique values from column A to the 'Unique data' sheet, and write sheet & file details (if not already written)
                        .Range(.Cells(1, intColNode), .Cells(lr, intColNode)).AdvancedFilter xlFilterCopy, , y, True
                        If Not boolWritten Then
                            y.Offset(0, -1).Value = ws.Name
                            y.Offset(0, -2).Value = ws.Parent.Name
                        End If

                         ' Delete the column header copied to the list
                        y.Delete Shift:=xlUp
                    End If
                End If

         ' Identify the next row, based on the most rows used in columns C & D
                lngLastNode = wksSummary.Cells(wksSummary.Rows.Count, 3).End(xlUp).Row
                lngLastScen = wksSummary.Cells(wksSummary.Rows.Count, 4).End(xlUp).Row
                lngNextRow = WorksheetFunction.Max(lngLastNode, lngLastScen) + 1
                If (lngNextRow - lngStartRow) > 1 Then



                     ' Fill down the workbook and sheet names
                    z.Resize(lngNextRow - lngStartRow, 2).FillDown
                    If (lngNextRow - lngLastNode) > 1 Then
                         ' Fill down the last Node value
                        wksSummary.Range(wksSummary.Cells(lngLastNode, 3), wksSummary.Cells(lngNextRow - 1, 3)).FillDown
                    End If
                    If (lngNextRow - lngLastScen) > 1 Then
                         ' Fill down the last Scenario value
                        wksSummary.Range(wksSummary.Cells(lngLastScen, 4), wksSummary.Cells(lngNextRow - 1, 4)).FillDown
                    End If
                End If



                Set y = wksSummary.Cells(lngNextRow, 3)
                Set r = y.Offset(0, 1)
                Set z = y.Offset(0, -2)
                lngStartRow = y.Row
            End If
        End With
    Next ws
wb.Close savechanges:=False 'close the workbook do not save
Set wb = Nothing 'release the object
End If

Next 'End of the fileNames loop
Set fileNames = Nothing

 ' Autofit column widths of the report
wksSummary.Range("A1:D1").EntireColumn.AutoFit

' Reset system settings
With Application
   .Calculation = xlCalculationAutomatic
   .ScreenUpdating = True
   .Visible = True
End With
End Sub

Answer 1

如果我理解正确，您希望将不可读的文件名写入新的worksheet。如果是这样，试试这个快速而又脏的：

手动添加新的worksheet到您的主文件，例如＆＃34;跳过＆＃34;和在开头宣布它：

Dim wksSkipped As Worksheet

Set wksSkipped = ThisWorkbook.Worksheets("Skipped")

替换此

If wb Is Nothing Then
Debug.Print "Error when loading " & fileNames(Key)

用这个

If wb Is Nothing Then
wksSkipped.Cells(wksSkipped.Cells(wksSkipped.Rows.Count, "A").End(xlUp).Row + 1, 1) = wb.Name

如果您的工作簿不可读，它会在新工作表中查看A列中的下一个空闲单元格，并记下不可读文件的文件名。

将跳过的文件名转换为Excel工作表

1 个答案: