Help amending this to loop through all files in folder

hello my peers,

i need your help. I have the below code that works on a single file that copy and pastes the required data into "Cost Savings" sheet in the active workbook.

When I have tried to introduce a loop and perform this code on all files in a fodler i cannot get it to work.

Im a novice so excuse the school boy shout out for help!

Sub Import()

    Dim vFile       As Variant
    Dim wbCopyTo    As Workbook
    Dim wsCopyTo    As Worksheet
    Dim wbCopyFrom  As Workbook
    Dim wsCopyFrom  As Worksheet
    

    Set wbCopyTo = ActiveWorkbook
    Set wsCopyTo = wbCopyTo.Sheets("Cost Savings")

Application.DisplayAlerts = False

    vFile = Application.GetOpenFilename
    
    If TypeName(vFile) = "Boolean" Then
        Exit Sub
    Else
    Set wbCopyFrom = Workbooks.Open(vFile)
    Set wsCopyFrom = wbCopyFrom.Worksheets(1)

    Application.CutCopyMode = False

    End If
    
        
Set oneRange = Range("A15:l1000")
Set aCell = Range("A1")

oneRange.Sort Key1:=aCell, Order1:=xlAscending, Header:=xlYes
        
    wsCopyFrom.Range("A15:R2000").Copy
    wsCopyTo.Range("A2").PasteSpecial Paste:=xlValues, _
            Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            


wbCopyFrom.Close False

    Columns("O:Q").Select
    Selection.NumberFormat = "#,##0.00"
    Columns("O:Q").Select
    Selection.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
    Columns("R:R").Select
    Selection.NumberFormat = "0.00%"
    Range("S1").Select
    
  With ActiveSheet
            .AutoFilterMode = False
            With Range("d1", Range("c" & Rows.Count).End(xlUp))
                .AutoFilter 1, "*total*"
                On Error Resume Next
                .Offset(1).SpecialCells(12).EntireRow.Delete
            End With
            .AutoFilterMode = False
        End With

        On Error Resume Next
        Range("A1:A3000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        Application.ScreenUpdating = True
        
 
        

End Sub

Open in new window

zack carterProject AnalystAsked:
Who is Participating?
 
NorieConnect With a Mentor VBA ExpertCommented:
Zack

If you need to select the folder add this function.
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    .InitialFileName = strPath
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function

Open in new window

Now in the code I posted change this,
strPath = "C:\Test\"

Open in new window

to this.
    strPath = GetFolder("C:\")   ' change C:\ if you want to start in a different folder.
    
    If strPath = "" Then
        MsgBox "No folder selected!", vbCritical
        Exit Sub
    End If

Open in new window

1
 
NorieConnect With a Mentor VBA ExpertCommented:
Perhaps this will give you a start, change strPath for the folder your files are in.
Sub Import()

    Dim vFile       As Variant
    Dim wbCopyTo    As Workbook
    Dim wsCopyTo    As Worksheet
    Dim wbCopyFrom  As Workbook
    Dim wsCopyFrom  As Worksheet
    Dim oneRange As Range
    Dim aCell As Range
    Dim strPath As String
    
    Application.DisplayAlerts = False

    Set wbCopyTo = ActiveWorkbook
    Set wsCopyTo = wbCopyTo.Sheets("Cost Savings")

    strPath = "C:\Test\"
    
    vFile = Dir(strPath & "*.xls*")
    
    Do
    
        Set wbCopyFrom = Workbooks.Open(strPath & vFile)
        Set wsCopyFrom = wbCopyFrom.Worksheets(1)

        
        With wsCopyFrom
        
            Set oneRange = .Range("A15:l1000")
            Set aCell = .Range("A1")

            oneRange.Sort Key1:=aCell, Order1:=xlAscending, Header:=xlYes
        
            wsCopyFrom.Range("A15:R2000").Copy
            
            wsCopyTo.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlValues, _
                Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            

            wbCopyFrom.Close False
        End With
        
        With wsCopyTo
            .Columns("O:Q").NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
            .Columns("R:R").NumberFormat = "0.00%"
    
            .AutoFilterMode = False
            
            With .Range("d1", .Range("c" & Rows.Count).End(xlUp))
                .AutoFilter 1, "*total*"
                
                On Error Resume Next
                .Offset(1).SpecialCells(12).EntireRow.Delete
                On Error GoTo 0
                
            End With
            
            .AutoFilterMode = False
        
            On Error Resume Next
            .Range("A1:A3000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
            On Error GoTo 0
            
        End With
        
        vFile = Dir
        
        Application.CutCopyMode = False
        
    Loop Until Len(vFile) = 0

End Sub

Open in new window

0
 
zack carterConnect With a Mentor Project AnalystAuthor Commented:
Hi Norie,

Thank you it works finally!

is there a way to change the below so its not hard coded but a user can select the folder required?

strPath = "C:\Test\"

Open in new window

0
 
Fabrice LambertConnect With a Mentor Fabrice LambertCommented:
Well, your function need some work to be called in a loop.

First, add a parameter (the path of the source workbook).
Second, get rid of activeWorkbook, Selection objects (these are chaotics and dangerous).
Third, split it into 2 unction, one doing the import, one doing the formatting.
Fourth, you don't need to select ranges, it is slow as hell.
Fifth, files existance should be done outside the function (uneeded defencive programming).
Sixth, when you change an application parameter, be sure to restore it.

Finally, you'll find your code reworked below, as well as a sample function executing a loop over multiple files.
File paths are in a collection, but it can be something else.
Public Sub sample()
    Dim files As Collection
    Set files = New Collection
    
    files.Add "c:\........\file1.xlsx"
    files.Add "c:\........\file2.xlsx"
    files.Add "c:\........\file3.xlsx"
    files.Add "c:\........\file4.xlsx"
    
    Dim file As Variant
    For Each file In files
        Application.DisplayAlerts = False
        import file
        Application.DisplayAlerts = True
    Next
End Sub

Public Sub import(ByVal path As String)
    Dim wbCopyTo As Excel.Workbook
    Set wbCopyTo = ThisWorkbook
    
    Dim wsCopyTo As Excel.Worksheet
    Set wsCopyTo = wbCopyTo.Sheets("Cost Savings")
    
    Dim wbCopyFrom As Excel.Workbook
    Set wbCopyFrom = Application.Workbooks.Open(vFile)

    Dim wsCopyFrom As Excel.Worksheet
    Set wsCopyFrom = wbCopyFrom.Worksheets(1)
    
    Dim oneRange As Excel.Range
    Set oneRange = Range("A15:l1000")
    
    Dim aCell As Excel.Range
    Set aCell = Range("A1")
    
    oneRange.Sort Key1:=aCell, Order1:=xlAscending, Header:=xlYes
    Application.CutCopyMode = False
    wsCopyFrom.Range("A15:R2000").Copy
    wsCopyTo.Range("A2").PasteSpecial Paste:=xlValues, _
            Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = True
    Set wsCopyFrom = Nothing
    wbCopyFrom.Close False
    Set wbCopyFrom = Nothing
    doFormatting wsCopyTo
End Sub

Private Sub doFormatting(ByRef ws As Excel.Worksheet)
    Dim rng As Excel.Range
    Set rng = ws.Columns("O:Q")
    rng.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(@_)"
    
    Set rng = ws.Columns("R:R")
    rng.NumberFormat = "0.00%"
    
    With ws
        .AutoFilterMode = False
        With Range("d1", ws.Range("c" & Rows.Count).End(xlUp))
            .AutoFilter 1, "*total*"
            On Error Resume Next
            .Offset(1).SpecialCells(12).EntireRow.Delete
        End With
        .AutoFilterMode = False
    End With
    ws.Range("A1:A3000").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

Open in new window

0
 
zack carterConnect With a Mentor Project AnalystAuthor Commented:
Thank you both for your input i will now go away and have a look at both codes and learn from what you have presented to me.
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.