stewart1
Board Regular
- Joined
- Feb 25, 2010
- Messages
- 66
Good afternoon everyone,
I have had a lot of help with this code and my deepest thanks goes to the man who was so patient with me.
However, I need to try and amend the code to further suit my needs.
I have spent the last five hours searching for a solution and trying to amend the code myself, but alas, it has proven to be beyond me.
The code I have posted below works great; when I run the macro I can retrieve the "database" worksheet from every workbook. The trouble is I need to modify the code to search through any named sub folder and search through any named worksheet.
At present within the souce folder "departments" all sub folders are named "department 1", "department 2" etc.
Within these folders each workbook is named "department 1 use" and so on.
You can see I am somewhat tied. I need to be able to name a sub folder "admin" for example and the worksheet "admin tracker". Another folder "accounts" etc.
I believe my problem may lie with "matchreturn" function, but I cannot work out how to amend it.
Here is the code
Again the "database" worksheet within every workbook is retrieved just fine. I just need more flexibility with how the macro searches for these.
Finger crossed that someone can help!
Thanks for looking
I have had a lot of help with this code and my deepest thanks goes to the man who was so patient with me.
However, I need to try and amend the code to further suit my needs.
I have spent the last five hours searching for a solution and trying to amend the code myself, but alas, it has proven to be beyond me.
The code I have posted below works great; when I run the macro I can retrieve the "database" worksheet from every workbook. The trouble is I need to modify the code to search through any named sub folder and search through any named worksheet.
At present within the souce folder "departments" all sub folders are named "department 1", "department 2" etc.
Within these folders each workbook is named "department 1 use" and so on.
You can see I am somewhat tied. I need to be able to name a sub folder "admin" for example and the worksheet "admin tracker". Another folder "accounts" etc.
I believe my problem may lie with "matchreturn" function, but I cannot work out how to amend it.
Here is the code
Code:
Option Explicit
Sub Main()
Dim FSO As FileSystemObject ' Object '<--- FileSystemObject
Dim fsoFolder As Object ' Object '<--- Folder
Dim REX As Object ' Object '<--- RegExp
Dim WB As Workbook
Dim wksSource As Worksheet
Dim wksDest As Worksheet
Dim rngLastDestLog As Range
Dim rngLastNewLog As Range
Dim rngToCopy As Range
Dim rngFoundOld As Range
Dim lMatchDest As Long
Dim lMatchSource As Long
Dim strFolOrFilName As String
Dim strLastDestLog As String
Dim bolLookForExists As Boolean
Dim bolNewRecordsExist As Boolean
Dim arySourceVal As Variant
'// Change Main folder path to suit //
Const MAIN_FOL_PATH As String = "C:\Users\stewart\Desktop\play work\Before data is fetched - Copy\Department"
'// Set references to FSO and RegExp //
Set FSO = CreateObject("Scripting.FileSystemObject")
Set REX = CreateObject("VBScript.RegExp")
'// If we do not find the main folder in the prescribed path, bail now! //
If Not FSO.FolderExists(MAIN_FOL_PATH) Then
MsgBox "Contact Administrator..."
Exit Sub
End If
'// Disable events so that we don't get the msgbox's and such when we are planting //
'// vals in various cells. //
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'// For each subfolder in our main folder... //
For Each fsoFolder In FSO.GetFolder(MAIN_FOL_PATH).SubFolders
'// Get the folder's name... //
strFolOrFilName = fsoFolder.Name
'// ...and send it to MatchReturn to see if it is a valid named folder. If //
'// TRUE, return the name (via strFolOrFilName) of the file/wb we should find //
'// therein. //
If MatchReturn(REX, strFolOrFilName, " Use.xls", "^Department\ [0-9]+$") Then
'// If the file we are wanting to find exists... //
If FSO.FileExists(fsoFolder.Path & "\" & strFolOrFilName) Then
'// ...open it and ... //
Set WB = Workbooks.Open(fsoFolder.Path & "\" & strFolOrFilName, , True)
'// ...see if the sheet we want exists. If not, close the wb under the //
'// Else. You may want to add a msgbox under the Else, "sheet not found//
'// in WB.name" or something, so that you know it got skipped. //
If ShExists("DATABASE", WB) Then
'// If we found the worksheet in the child/source wb, set a reference//
Set wksSource = WB.Worksheets("DATABASE")
'// If there is a new department and no sheet for it, in //
'// ThisWorkbook, I was thinking just copy the source sheet and //
'// rename it. //
If Not ShExists(fsoFolder.Name & " DATABASE") Then
wksSource.Copy _
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Set wksDest = ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
wksDest.Name = _
UCase(Left(strFolOrFilName, _
InStrRev(strFolOrFilName, " Use.xls") - 1) & _
" DATABASE")
WB.Close False
Else
'// Else set a reference to the correct sheet in ThisWorkbook. //
Set wksDest = ThisWorkbook.Worksheets(fsoFolder.Name & " DATABASE")
'// You can 'un-REM' this while stepping thru (F8) to see what's//
'// going on. Delete when done. //
'Debug.Print wksDest.Name: wksDest.Parent.Activate: wksDest.Select
With wksDest
'// Set a reference to the last cell in Col A that has a //
'// val (log#). Note: our search range is from A2 to the //
'// bottom of the sheet. We search (read thru the Function)//
'// from "after" the first cell and we are searching //
'// xlPrevious (upwards), so we are actually searching from //
'// the bottommost cell. //
Set rngLastDestLog = _
RangeFound(.Range(.Cells(2, 1), .Cells(.Rows.Count, 1)))
'// If we find a cell with a log#, rngLastDestLog will NOT //
'// be NOTHING, that is, it will be something (a Range //
'// Object), so we pass the test. //
If Not rngLastDestLog Is Nothing Then
'// so we have a log# to look for... //
bolLookForExists = True
'// and we'll grab its value //
strLastDestLog = rngLastDestLog.Value
lMatchDest = rngLastDestLog.Row + 1
Else
bolLookForExists = False
strLastDestLog = vbNullString
lMatchDest = 2
End If
End With
'// Now with our child/source wb... //
With wksSource
'// Find the last last log# as before. //
Set rngLastNewLog = _
RangeFound(.Range(.Cells(2, 1), .Cells(.Rows.Count, 1)))
'// In case the source sheet has log#(s), but hasn't had any//
'// new ones added since we last ran our code, we need an //
'// additional test. If either rngLastNewLog IS NOTHING //
'// (ie - the sheet is there, but there's no records yet), //
'// or if the last log# is equal to the last log# in our //
'// destination wb (ThisWorkbook), we know there's no //
'// records to copy. //
If Not rngLastNewLog Is Nothing Then
bolNewRecordsExist = _
Not rngLastNewLog.Value = strLastDestLog
Else
bolNewRecordsExist = False
End If
'// If we have new records to copy... //
If bolNewRecordsExist Then
'// if there were no log#s in the destination sheet, we //
'// need to copy all records in the source sheet. //
If Not bolLookForExists Then
Set rngToCopy = _
.Range(.Range("A2"), rngLastNewLog.Offset(, 11))
Else
'// Else we will attempt to find the last log# from //
'// the destination sheet. Note that as we are not //
'// just looking for the last row, we include //
'// the FindWhat arg. //
Set rngFoundOld = _
RangeFound(.Range(.Cells(2, 1), _
.Cells(.Rows.Count, 1)), _
strLastDestLog, , , xlWhole)
'// If amongst the records in the source sheet, we //
'// find the correct log#, we set the range from //
'// one row below it, to the last current record in //
'// the source sheet. //
If Not rngFoundOld Is Nothing Then
Set rngToCopy = _
.Range(rngFoundOld.Offset(1), _
rngLastNewLog.Offset(, 11))
Else
'// Else we need all the records from source sht//
Set rngToCopy = _
.Range(.Range("A2"), rngLastNewLog.Offset(, 11))
End If
'SAA
'Debug.Print rngToCopy.Parent.Parent.Name & " Sheet: " & _
rngToCopy.Parent.Name & " " & _
rngToCopy.Address
End If
'// Plunk the vals from our determined range into an //
'// array. //
arySourceVal = rngToCopy.Value
Else
'// Nothing to copy //
strLastDestLog = vbNullString
lMatchDest = 0
lMatchSource = 0
WB.Close False
GoTo NextLoop
End If
End With
'// Back to our destination sheet. //
With wksDest
'// I had issues, probably related to resetting the module //
'// while coding. Anyways, just seems cheap insurance. //
.Protect Password:="MyPassword", userinterfaceonly:=True
'// Size our destination array, from the row below the last //
'// log#, to that row + the ubound of the first dimension of//
'// our array (which will equal how many rows we plunked into//
'// our array) - 1, from column 1 to column 12/"L". //
'// Plunk the array into the equally sized range. //
.Range(.Cells(lMatchDest, 1), _
.Cells(lMatchDest + UBound(arySourceVal, 1) - 1, "L") _
).Value = arySourceVal
End With
WB.Close False
End If
Else
WB.Close False
Set WB = Nothing
End If
End If
End If
NextLoop:
Next
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Function MatchReturn(REX As Object, _
NameString As String, _
TackOn As String, _
REXPattern As String, _
Optional REXGlobal As Boolean = False, _
Optional REXIgnoreCase As Boolean = True _
) As Boolean
With REX
.Global = REXGlobal
.IgnoreCase = REXIgnoreCase
.Pattern = REXPattern
MatchReturn = .Test(NameString)
End With
If Not MatchReturn Then
NameString = vbNullString
Exit Function
Else
NameString = NameString & TackOn
End If
End Function
Function ShExists(ShName As String, _
Optional WB As Workbook, _
Optional CheckCase As Boolean = False) As Boolean
If WB Is Nothing Then
Set WB = ThisWorkbook
End If
If CheckCase Then
On Error Resume Next
ShExists = CBool(WB.Worksheets(ShName).Name = ShName)
On Error GoTo 0
Else
On Error Resume Next
ShExists = CBool(UCase(WB.Worksheets(ShName).Name) = UCase(ShName))
On Error GoTo 0
End If
End Function
Function RangeFound(SearchRange As Range, _
Optional FindWhat As String = "*", _
Optional StartingAfter As Range, _
Optional LookAtTextOrFormula As XlFindLookIn = xlValues, _
Optional LookAtWholeOrPart As XlLookAt = xlPart, _
Optional SearchRowCol As XlSearchOrder = xlByRows, _
Optional SearchUpDn As XlSearchDirection = xlPrevious, _
Optional bMatchCase As Boolean = False) As Range
If StartingAfter Is Nothing Then
Set StartingAfter = SearchRange(1)
End If
Set RangeFound = SearchRange.Find(What:=FindWhat, _
After:=StartingAfter, _
LookIn:=LookAtTextOrFormula, _
LookAt:=LookAtWholeOrPart, _
SearchOrder:=SearchRowCol, _
SearchDirection:=SearchUpDn, _
MatchCase:=bMatchCase)
End FunctionAgain the "database" worksheet within every workbook is retrieved just fine. I just need more flexibility with how the macro searches for these.
Finger crossed that someone can help!
Thanks for looking
