通过目录循环过滤代码
我有一个代码，执行一些高级filter，并在工作簿中创build一个新工作表。 我需要添加一个代码，可以循环通过一个目录，不会错过任何工作表。
有人能帮忙吗？ 我已经在网上尝试了通用的，并且似乎无法让它在目录中的第一个工作簿上工作。
Sub Looper() 'atv5 + extra splitting of scen names(+,-,etc). 'looping dir 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 Dim boolWritten As Boolean, lngNextRow As Long Dim intColNode As Integer, intColScenario As Integer Dim intColNext As Integer ' 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) .Range("A1:D1").Value = Array("File Name", "Sheet Name", "Node Name", "Scenario Name") End With ' 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, -3).Value = ws.Name r.Offset(0, -2).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, -2).Value = ws.Name y.Offset(0, -1).Value = ws.Parent.Name End If ' Delete the column header copied to the list y.Delete Shift:=xlUp End If ' Identify the next row, based on the most rows used in columns C & D lngNextRow = WorksheetFunction.Max(wksSummary.Cells(wksSummary.Rows.Count, 3).End(xlUp).Row, wksSummary.Cells(wksSummary.Rows.Count, 4).End(xlUp).Row) + 1 Set y = wksSummary.Cells(lngNextRow, 3) Set r = y.Offset(0, 1) End If End If End With Next ws ' Autofit column widths of the report wksSummary.Range("A1:D1").EntireColumn.AutoFit ' Reset system settings With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End Sub 编辑8月24日
Sub looperv2() 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 ' 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 ' 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 lngNextRow = WorksheetFunction.Max(wksSummary.Cells(wksSummary.Rows.Count, 3).End(xlUp).Row, wksSummary.Cells(wksSummary.Rows.Count, 4).End(xlUp).Row) + 1 If (lngNextRow - lngStartRow) > 1 Then z.Resize(lngNextRow - lngStartRow, 2).FillDown 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 ' Autofit column widths of the report wksSummary.Range("A1:D1").EntireColumn.AutoFit ' Reset system settings With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End Sub
这里你稍微修改你的代码：
Sub looperv2() Dim wb As Workbook, fileNames As Object, errCheck As Boolean 'I have added this Sept 9, 2015 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 ' 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 'I added the below Sept 9, 2015 Set fileNames = CreateObject("Scripting.Dictionary") 'I added the below Sept 9, 2015 errCheck = UserInput.FileDialogDictionary(fileNames) 'I added the below Sept 9, 2015 If errCheck Then 'I added the below Sept 9, 2015 Exit Sub 'I added the below Sept 9, 2015 End If 'I added the below Sept 9, 2015 ''' For Each Key In fileNames 'loop through the dictionary I added the below Sept 9, 2015 Set wb = Workbooks.Open(fileNames(Key)) 'I added the below Sept 9, 2015 wb.Application.Visible = False 'make it not visible I added the below Sept 9, 2015 ' 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 lngNextRow = WorksheetFunction.Max(wksSummary.Cells(wksSummary.Rows.Count, 3).End(xlUp).Row, wksSummary.Cells(wksSummary.Rows.Count, 4).End(xlUp).Row) + 1 If (lngNextRow - lngStartRow) > 1 Then z.Resize(lngNextRow - lngStartRow, 2).FillDown 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.Application.Visible = True '' I added this Sept 9, 2015 wb.Close savechanges:=False ' I added this Sept 9, 2015 Set wb = Nothing 'release the object ' I added this Sept 9, 2015 Next 'End of the fileNames loop ' I added this Sept 9, 2015 Set fileNames = Nothing ' I added this Sept 9, 2015 ' Autofit column widths of the report wksSummary.Range("A1:D1").EntireColumn.AutoFit ' Reset system settings With Application .Calculation = xlCalculationAutomatic .ScreenUpdating = True End With End Sub
和我的文件对话框代码，我已经使用，因为它已被写入。 如果要使用文件夹位置，则可以使用文件对话框文件夹select器选项。 然后只是使用一个字典，并循环目录中的所有文件，我build议使用dir函数并testing.xls或类似的东西。
Function FileDialogDictionary(ByRef file As Object) As Boolean ' returns true if the user cancels 'Declare a variable as a FileDialog object. Dim fd As FileDialog Dim item As Variant Dim i As Long 'Create a FileDialog object as a File Picker dialog box. file.RemoveAll 'clear the dictionary Set fd = Application.FileDialog(msoFileDialogFilePicker) 'Declare a variable to contain the path 'of each selected item. Even though the path is a String, 'the variable must be a Variant because For Each...Next 'routines only work with Variants and Objects. 'Use a With...End With block to reference the FileDialog object. With fd 'Use the Show method to display the File Picker dialog box and return the user's action. 'The user pressed the action button. .Title = "Select Excel Workbooks" 'Change this to suit your purpose .AllowMultiSelect = True .Filters.Clear .Filters.Add "Microsoft Excel files", "*.xlsx,*.xls" If .Show = -1 Then 'Step through each string in the FileDialogSelectedItems collection. For Each item In .SelectedItems 'loop through all selected and add to dictionary i = i + 1 file.Add i, item Next item FileDialogDictionary = False 'The user pressed Cancel. Else FileDialogDictionary = True Set fd = Nothing Exit Function End If End With Set fd = Nothing 'Set the object variable to Nothing. End Function
像这样的东西会工作，我想：
Dim incomingFolderPath = "YOUR DIRECTORY HERE" Dim archiveFolderPath As String = "Archive directory here" While Directory.GetFiles(incomingFolderPath).Length > 0 Dim myFile as string = Dir(incomingFolderPath & "\*.*") Dim fileToOpen As String = incomingFolderPath + myFile 'Logic here System.IO.File.Move(fileToOpen, archiveFolderPath) End While
这个想法是检查文件夹是否有任何内容，如果它使用你的逻辑，然后将该文件移动到另一个位置。 它将循环直到所有文件都被移动。 不知道这是否是你以后，但它应该帮助。