Looping Filter Code through Directory

Question

I have a code that does some advanced filters and creates a new sheet in the workbook. I need to add a code that can loop it through a directory and not miss any sheets.

Can anyone help with this? I've tried the generic ones online and just can't seem to get it to work on a workbook after the first one in the directory.

    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

EDIT Aug 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

Answer 1

Here you go your code modified slightly:

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

and my file dialog code which I reused because it was already written. If you want to use a folder location you can use the file dialog folder picker option. Then just use a dictionary and loop through all files in the directory I suggest using the dir function and test for .xls or something like that.

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

Answer 2

Something like this would work I think:

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

The idea is it would check to see if the folder has anything in it, if it does it would use your logic then move that file to another location. It will loop through this until all files are moved. Not sure if this is exactly what you're after but it should help.