Running a script from a blank workbook and apply to specific files in specific folder

[Beatrix]

Hi Everyone ,

I've got below script which works great and applies to the worksheets in active workbook but I need to copy this script in a blank workbook and insert a macro button for users to click and process the workbooks in a specific folder. I guess I need to use Do While Loop for this but I am not sure thoughCan anyone tell me how can I edit this script to be able to do that please?

Sub CreateSummaryMax2Min()

    ' Macro to create summary table containing the _
    Min, Max, And 3 Quartiles of each sheet in _
    the workbook. The user is requsted to _
    input the first cell of the range for the _
    calculations. In addition the value of the _
    row at "Z" (in any cells) is entered in the _
    table.
    
    Dim rInp As Range, rOut As Range, rFnd As Range, rSrch As Range
    Dim wsIn As Worksheet, wsSum As Worksheet
    Dim IR As Long
    Dim vOut As Variant
    Const sZZZ As String = "Z" 'This is the value to indicate special row
 
    
    ' Check if Summary sheet exists, else create
    On Error Resume Next 'in case it doesn't exist
    Set wsSum = Sheets("SummaryMax2Min")
    On Error GoTo 0 'reset error behaviour
    If wsSum Is Nothing Then 'sheet does not exist
        Set wsSum = Sheets.Add(after:=Sheets(Sheets.Count))
        wsSum.Name = "SummaryMax2Min"
    End If
    Set rOut = wsSum.Range("D2")
    
    'for our output we will gather the data into an array _
    Then print out a row at once For Each sheet _
   first the header:
    ReDim vOut(1 To 1, 1 To 7)
    vOut(1, 2) = "Z"
    vOut(1, 3) = "Max"
    vOut(1, 4) = "Q3"
    vOut(1, 5) = "Q2"
    vOut(1, 6) = "Q1"
    vOut(1, 7) = "Min"
    rOut.Resize(1, 7).Value = vOut 'print headers to sheet
    Set rOut = rOut.Offset(1, 0) 'set to next row
    
    
    ' Now go through each sheet, get user to enter _
    range For processing. Then calculate quartiles _
    And add the "Z" figure.
    
    For Each wsIn In Sheets
        If wsIn.Name <> wsSum.Name Then
GetRange:
            wsIn.Activate
            Set rInp = Application.InputBox( _
            prompt:="Please select 1st cell of range in this sheet " _
            & vbCrLf & "to be processed for Quartiles." & vbCrLf _
            & "You can use your mouse to select", _
            Title:="Select Quartiles Range", _
            Type:=8)
            If rInp Is Nothing Then GoTo GetRange 'loop if invalid input
            If rInp.Columns.Count > 1 Or rInp.Parent.Name <> wsIn.Name _
            Then GoTo GetRange 'loop if multiple columns selected or on wrong sheet
            
            'extend range to end of sheet
            IR = wsIn.Cells(Rows.Count, rInp.Column).End(xlUp).Row ' last row, now skip summary if exists
            If wsIn.Cells(IR, rInp.Column).Offset(-1, 0) = vbNullString Then 'there is a summary line,
            IR = wsIn.Cells(IR, rInp.Column).End(xlUp).Row 'exclude it
            End If
            
            Set rInp = rInp.Cells(1, 1).Resize(IR - rInp.Row + 1, 1)
            'calculate quartiles from provided range
            With Application.WorksheetFunction
                vOut(1, 1) = wsIn.Name
                vOut(1, 3) = .Min(rInp, 1)
                vOut(1, 4) = .Quartile(rInp, 2)
                vOut(1, 5) = .Quartile(rInp, 3)
                vOut(1, 6) = .Max(rInp)
            End With
            
            'find "Z"
            Set rSrch = wsIn.Cells
            Set rFnd = rSrch.Find(what:=sZZZ, after:=Cells(rInp.Row - 1, 3), _
            lookat:=xlWhole, LookIn:=xlValues, _
            searchdirection:=xlNext)
            If rFnd Is Nothing Then ' not found
                vOut(1, 2) = vbNullString
            Else ' get value at intersection of column and row
                vOut(1, 2) = Intersect(rInp, wsIn.Rows(rFnd.Row)).Value
                
            End If
            rOut.Resize(1, 7).Value = vOut 'print values to sheet
            Set rOut = rOut.Offset(1, 0) ' set to next row
            
        End If
    Next wsIn
    
    'format table
    Set rOut = rOut.Offset(-1, 0).CurrentRegion
    FormatSumTbl rOut
    
CleanUp:
    Set wsIn = Nothing
    Set wsSum = Nothing
    Set rOut = Nothing
    Set rInp = Nothing
    Set rFnd = Nothing
    Set rSrch = Nothing
    
    
End Sub


Sub FormatSumTbl(rTbl As Range)

    ' FormatSumTbl Macro
    ' Format the Summary Table & headings
    
    With rTbl
        .HorizontalAlignment = xlCenter
        .NumberFormat = "0.0"
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        With .Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With .Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With .Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With .Columns(1)
            .Borders(xlInsideHorizontal).LineStyle = xlNone
            .EntireColumn.AutoFit
            With .Font
                .Color = -16776961
                .TintAndShade = 0
            End With
        End With
        With .Rows(1)
            .Font.Underline = xlUnderlineStyleSingle
        End With
        With .Columns(2)
            .Font.Bold = True
            .Font.Underline = xlNone
        End With
        With Cells(1, 2).Font
            .Color = 16776961
            .TintAndShade = 0
        End With
    End With
End Sub

[westconn1]

to process all files in a folder

mypath = "C:\temp\"    ' change to suit
fname = dir(mypath & "*.xls")   ' change file extension to suit
do while len(fname) > 0
  set wb = workbooks.open(mypath & fname)
  ' your code here
  'all sheets and ranges should now be fully qualified to workbook like
  Set wsSum = wb.Sheets("SummaryMax2Min")
  ' rest of code
  wb.close true  ' to save or false to close without saving
  fname = dir   ' get next filename
loop

[Beatrix]

Hi westconn1,

Thank you for your reply. I am testing it now but got confused. Where below line goes in script?

Set wsSum = wb.Sheets("SummaryMax2Min")

Cheers
B.

to process all files in a folder

mypath = "C:\temp\"    ' change to suit
fname = dir(mypath & "*.xls")   ' change file extension to suit
do while len(fname) > 0
  set wb = workbooks.open(mypath & fname)
  ' your code here
  'all sheets and ranges should now be fully qualified to workbook like
  Set wsSum = wb.Sheets("SummaryMax2Min")
  ' rest of code
  wb.close true  ' to save or false to close without saving
  fname = dir   ' get next filename
loop

[Beatrix]

Hi westconn1 ,

Please ignore my previous reply. I figured it out. It's working! Thanks very much for your help I have better understanding for Do While Loop

Cheers
B.

[Kenneth Hobs]

The Dir() method works fine if your files are all in that parent folder.

This method will optionally search the subfolders as well.

'http://www.ozgrid.com/forum/showthread.php?t=157939
Sub test()
    Dim myDir As String, temp(), myList, myExtension As String
    Dim SearchSubFolders As Boolean, Rtn As Integer, msg As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show Then
            myDir = .SelectedItems(1)
        End If
    End With
    msg = "Enter File name and Extension" & vbLf & "following wild" & _
    " cards can be used" & vbLf & "* # ?"
    myExtension = Application.InputBox(msg)
    If (myExtension = "False") + (myExtension = "") Then Exit Sub
    Rtn = MsgBox("Include Sub Folders ?", vbYesNo)
    SearchSubFolders = Rtn = 6
    myList = SearchFiles(myDir, myExtension, 0, temp(), SearchSubFolders)
    If Not IsError(myList) Then
        Sheets(1).Cells(1).Resize(UBound(myList, 2), 2).Value = _
        Application.Transpose(myList)
    Else
        MsgBox "No file found"
    End If
End Sub
 

'http://www.ozgrid.com/forum/showthread.php?t=157939
Sub Test_SearchFiles()
  Dim v As Variant, a() As Variant
  SearchFiles ThisWorkbook.Path, "*.xls", 0, a(), True
  For Each v In a()
    Debug.Print v
  Next v
End Sub
 
 
Private Function SearchFiles(myDir As String _
    , myFileName As String, n As Long, myList() _
    , Optional SearchSub As Boolean = False) As Variant
    Dim fso As Object, myFolder As Object, myFile As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    For Each myFile In fso.getfolder(myDir).Files
        Select Case myFile.Attributes
        Case 2, 4, 6, 34
        Case Else
            If (Not myFile.Name Like "~$*") _
            * (myFile.Path & "\" & myFile.Name <> ThisWorkbook.FullName) _
            * (UCase(myFile.Name) Like UCase(myFileName)) Then
                n = n + 1
                ReDim Preserve myList(1 To 2, 1 To n)
                myList(1, n) = myDir
                myList(2, n) = myFile.Name
            End If
        End Select
    Next
    If SearchSub Then
        For Each myFolder In fso.getfolder(myDir).subfolders
            SearchFiles = SearchFiles(myFolder.Path, myFileName, _
            n, myList, SearchSub)
        Next
    End If
    SearchFiles = IIf(n > 0, myList, CVErr(xlErrRef))
End Function