Option Explicit
' MrKowz : April 11, 2011 : [URL]http://www.mrexcel.com/forum/showthread.php?t=542636[/URL]
' This macro will open files A1001 through A4301 and copy all records whose date is
' between 10/10/1990 and 01/01/2011, and who was paid less than $500.
' Consistencies:
' * Data for each worksheet lies in the sheet "ClientsRec"
' * The date to check lies in Column D
' * The pay to check lies in Column S
' Notes:
' * Store this code in a {{NEW}} workbook that is in the same folder as the files to check
' * This code WILL take a long time to run. Consider allowing this to run in its
' entirity when you do not need to use the computer for a couple of hours.
' * If you choose to run a trial, it will check the first ten files so you can manually
' check to ensure it is capturing all of the data you need.
Public Sub ChecksReport()
' Variable Declaration:
' dWB, dWS, sWB, sWS - Refers to the Destination Workbooks/Worksheets and the Source Workbooks/Worksheets
' parentdirec, fName - String variables that contain the path and filename of each workbook
' rowx - Row to copy the record to. This is increased by 1 whenever a copy is performed
' sLR, i - sLR is the last row of the Source (current) worksheet, and i is used to loop through all rows
' trial, MaxWB, wbCount - trial is used to determine if you want to run a trial or run the entire code
' MaxWB, wbCount - wbCount is a number from 1001 to MaxWB. MaxWB is determined using the trial variable, and can
' either be a value of 1010 (trial run) or 4301 (full run)
Dim wbCount As Long, _
parentdirec As String, _
fName As String, _
dWB As Workbook, _
dWS As Worksheet, _
sWB As Workbook, _
sWS As Worksheet, _
rowx As Long, _
sLR As Long, _
i As Long, _
trial As VbMsgBoxResult, _
MaxWB As Long
' Variable Initialization
' Sets the dWB/dWS variables as the current workbook/worksheet (the workbook/worksheet you want the data to be copied TO)
' Defines rowx = 2 so that the first record found is copied to row 2
' Defines parentdirec as the folder path that this workbook is currently in.
Set dWB = ActiveWorkbook
Set dWS = dWB.ActiveSheet
rowx = 2
parentdirec = ActiveWorkbook.Path
' Application Initialization
' Turns off ScreenUpdating, Calculations, and Alerts so that the macro can run at optimal speed
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
' Trial
' Message Box asking if a trial run is desired. Yes will perform a trial that will perform the macro on
' workbooks A1001 through A1010. Otherwise, it will run on all workbooks A1001 through A4301.
trial = MsgBox("Would you like to run a test of this macro?", vbYesNo, "Trial Run")
If trial = vbYes Then
MaxWB = 1010
Else
MaxWB = 4301
End If
' Main Loop
' Loops through every workbook from A1001 through the MaxWB variable
For wbCount = 1001 To MaxWB
' Open File
' fName use the wbCount variable to complete the filename of the next file to open.
' Then open the filename by referring to the parentdirec folder and the current fName
fName = "A" & wbCount & ".xls"
Application.StatusBar = "Currently opening " & fName
Workbooks.Open parentdirec & "\" & fName
' Source Workbook/Worksheets Initialization
' Sets the sWB/sWS variables as the workbook/worksheet that is currently being checked.
' Defines sLR to be the last row of the data found in column D.
Set sWB = Workbooks(fName)
Set sWS = sWB.Sheets("ClientsRec")
sLR = sWS.Range("D" & rows.Count).End(xlUp).Row
' Secondary Loop
' Loops through every row of the file currently being checked to determine if the date in
' column D is between October 10, 1990 and January 1, 2011; and also checks to see if the
' value in column S is less than or equal to $500.
For i = 1 To sLR
Application.StatusBar = "Currently checking row " & i & "/" & sLR & " in " & fName
If sWS.Range("D" & i).Value >= DateSerial(1990, 10, 10) And sWS.Range("D" & i).Value <= DateSerial(2011, 1, 1) And sWS.Range("S" & i).Value <= 500 Then
' Overflow Control
' If more than 65530 records are copied over, this will create an additional worksheet in your
' destination workbook since a file with a .xls extension has a maximum row capacity of 65536.
' If a new worksheet is created in this manner, rowx is reset to 2 so that data will resume copying over
' on row 2 of the new worksheet.
If rowx >= 65530 Then
dWB.Sheets.Add after:=Sheets(Sheets.Count)
Set dWS = dWB.ActiveSheet
rowx = 2
End If
' Copy Record
' Copies the current row in the source worksheet to the destination worksheet
' Increases the rowx variable by 1
sWS.rows(i).Copy Destination:=dWS.Range("A" & rowx)
rowx = rowx + 1
End If
Next i
' Close File
' Closes the file that was just checked.
Application.StatusBar = "Currently closing " & fName
sWB.Close
Next wbCount
' Reinstate Application Variables
' Turns back on ScreenUpdating, Automatic Calculations, Alerts, and resets the StatusBar
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
.StatusBar = False
End With
End Sub
