PDA

View Full Version : [SOLVED] Running a script from a blank workbook and apply to specific files in specific folder



Beatrix
02-06-2014, 10:29 AM
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 though:doh:Can anyone tell me how can I edit this script to be able to do that please?:help




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
02-07-2014, 02:28 AM
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
02-07-2014, 08:02 AM
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
02-07-2014, 08:29 AM
Hi westconn1 ,

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

Cheers
B.

Kenneth Hobs
02-07-2014, 12:03 PM
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