我有一个代码可以执行一些高级过滤器并在工作簿中创建一个新工作表。我需要添加一个代码，可以通过一个目录循环它，而不是错过任何工作表。
任何人都可以帮忙吗？我已经在网上尝试过通用的那些，但是在目录中的第一个工作簿之后，它似乎无法在工作簿上工作。
Sub Looper()
'a.t.v.5 + 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
答案 0 :(得分：1)
您可以稍微修改一下代码：
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
和我重复使用的文件对话框代码，因为它已经写好了。如果要使用文件夹位置，可以使用文件对话框文件夹选择器选项。然后只需使用字典并遍历我建议使用dir函数的目录中的所有文件，并测试.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
答案 1 :(得分：0)
我认为这样的事情会起作用：
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
这个想法是它会检查文件夹中是否有任何内容，如果是，它会使用你的逻辑然后将该文件移动到另一个位置。它会遍历这个，直到所有文件都被移动。 不确定这是否正是您所追求的，但它应该有所帮助。