Excel VBA

Extract from Directory

Here is another example of the customer saying, “why don’t you build it and I’ll tell you if you built what I envisioned.” I was told that they download 10 files every morning and they needed to suck the data out of one tab into a master workbook.

There are 3 sheets in the macro workbook

Main sheet with instructions and a big button to click
A headings sheet that will be copied into the created file
A sheet with two changable cells named FilePath and SavePath

Sub RunButton()
    'Sets up and builds daily file    Dim fPath   As String
    Dim sPath   As String
    Dim i       As Long
    Dim LastRow As Long
    Dim Answer  As String
    Dim oFSO    As Object
    Dim oFolder As Object
    Dim oFile   As Object
    
    On Error GoTo ErrHand
    Answer = Application.InputBox("Type the name to save to or accept suggestion", _
        "File Name", "InvWkst_Vend_" & Application.Text(Now() - 1, "mm-dd"))
    'Which folder? Uses ‘named’ cells
    sPath = [SavePath]
    fPath = [FilesPath]
    Workbooks.Add.SaveAs sPath & Answer & ".xlsx"
    
    Application.ScreenUpdating = False
    Workbooks(Answer).Activate
    LastRow = 1
    	'Copy headings from here
    ThisWorkbook.Sheets("Headings").Range("A1:T1").Copy
    Workbooks(Answer).Activate
    Cells(1, 1).Select
    ActiveSheet.Paste
    Range("2:2").Select
    ActiveWindow.FreezePanes = True
    	'Done with headings
    
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set oFolder = oFSO.GetFolder(fPath)
    
    For Each oFile In oFolder.Files
    If oFile.Name = Answer Then GoTo Skipper 'Didn't work
        With Workbooks.Open(oFile)
            Debug.Print oFile
            .Sheets("Worksheet").Range("A2:O10000").Copy
                Workbooks(Answer).Activate
                Cells(LastRow + 1, 1).Select
                ActiveSheet.Paste
                LastRow = Range("A665000").End(xlUp).Row    'LAST ROW
                ActiveWorkbook.Save

            .Close
            
        Application.StatusBar = "File: " & i & Chr(32) & Chr(32) & oFile.Name
            i = i + 1
        End With
Skipper:
    Next
    Application.StatusBar = False
    'turn screen updating back on
    Application.ScreenUpdating = True
    Workbooks(Answer).Activate
    Cells(2, 1).Select
    'Give feedback
    MsgBox "Completed writing " & i & " files to " & vbCrLf & sPath & Answer, vbInformation
    Exit Sub
ErrHand:
    MsgBox "Please report error " & Err.Number & vbCrLf & Err.Description, vbCritical
End Sub

When you email the file to the customer, you have to remember to tell them:

Save the file from email to your desktop
Do not run it from inside Outlook
Update the Parameters sheet with the right paths
Tell me what you REALLY want before I spend 3 days building it

Updated:	01/03/2025 14:36
This page added:	12 May 2015