LinkBack URL
About LinkBacks
My current code is working almost perfectly. The only problem is that it doesn't find all the instances of the files existence.
The code should search folders for items in column A, add a unique number and store it in that cell.
Example:
If 04062017003-1 is in column A
And 04062017003-1, 04062017003-2, 04062017003-3
all exist in the folders being searched, it should change the cell contents to 04062017003-4
I believe that if the search was done from the first subfolder to the last then the desired results would be produced. (In the example: 04062017003-3 could never exist prior to 04062017003-2 or 04062017003-1)
Folders are arranged in this manner
...2017
...2017\2017-01
...2017\2017-01\2017-01-01
2017-01-02
2017-01-03
2017-01-04
2017-01-05
2017-01-06
2017-01-07
2017-01-08
2017-01-09
2017-01-10
2017-01-11
2017-01-12
2017-01-13
2017-01-14
2017-01-15
2017-01-16
2017-01-17
2017-01-18
2017-01-19
2017-01-20
2017-01-21
2017-01-22
2017-01-23
2017-01-24
2017-01-25
2017-01-26
2017-01-27
2017-01-28
2017-01-29
2017-01-30
...2017\2017-02
...2017\2017-02\2017-02-01
2017-02-02
2017-02-03
2017-02-04
2017-02-05
2017-02-06
2017-02-07
2017-02-08
2017-02-09
2017-02-10
2017-02-11
2017-02-12
2017-02-13
2017-02-14
2017-02-15
2017-02-16
2017-02-17
2017-02-18
2017-02-19
2017-02-20
2017-02-21
2017-02-22
2017-02-23
2017-02-24
2017-02-25
2017-02-26
2017-02-27
2017-02-28
2017-02-29
2017-02-30
And so on...
Here is my current code:
With a form
Option Explicit Const cPATH As String = "P:\OS0101_Fort_Hills_MPG\010_FH_GDA\011-GDA_INSPECTION\02 - DAILY GDA FIELD INSPECTIONS\2017\" Const cEXT As String = ".xlsx" Sub CheckIfFileExists() Dim lFirstRow As Long Dim lLastRow As Long Dim c As Excel.Range On Error GoTo Catch lFirstRow = 2 lLastRow = Range("A" & Rows.Count).End(xlUp).Row frmXXX.Show vbModeless AddStatus "Started" For Each c In Range(Cells(lFirstRow, 1), Cells(lLastRow, 1)) AddStatus "Processing cell " & c.Address & " - Looking for " & StrConv(c.Value, vbUpperCase) If c.Value <> vbNullString Then CheckFolders cPATH, c End If Next AddStatus "Finished" Exit Sub Catch: MsgBox "ERROR: [" & Err.Number & "] " & Err.Description & vbCrLf & "Proc: CheckIfFileExists Line Number: " & Erl(), vbExclamation, "Error" End Sub Function CheckFolders(ByVal sPath As String, ByRef c As Excel.Range) As Boolean Dim FSO As Object Dim oFolder As Object Dim oSubFolder As Object Dim FileName As String On Error GoTo Catch Set FSO = CreateObject("Scripting.FileSystemObject") Set oFolder = FSO.GetFolder(sPath) For Each oSubFolder In oFolder.SubFolders AddStatus " Checking folder " & oSubFolder If Dir(oSubFolder.Path & "\" & c.Value & cEXT) <> vbNullString Then CheckFolders = True AddStatus "** FOUND **" If InStr(c.Value, "-") > 0 Then c.Value = Left(c.Value, InStr(c.Value, "-") - 1) & "-" & Val(Mid(c.Value, InStr(c.Value, "-") + 1) + 1) Else c.Value = c.Value & "-1)" End If AddStatus "Cell " & c.Address & " updated to " & c.Value AddStatus "------------------------------------------" Else CheckFolders = CheckFolders(oSubFolder.Path, c) End If Next Exit Function Catch: MsgBox "ERROR: [" & Err.Number & "] " & Err.Description & vbCrLf & "Proc: CheckFolders Line Number: " & Erl(), vbExclamation, "Error" End Function Public Sub AddStatus(strStatus As String) On Error GoTo Catch With frmXXX.lb .AddItem Format(Now, "hh:mm:ss") .List(.ListCount - 1, 1) = strStatus If frmXXX.chkReview.Value = False Then .ListIndex = .ListCount - 1 End If End With DoEvents Exit Sub Catch: MsgBox "ERROR: [" & Err.Number & "] " & Err.Description & vbCrLf & "Proc: AddStatus Line Number: " & Erl(), vbExclamation, "Error" End Sub
Option Explicit Private Sub CommandButton1_Click() Unload Me End Sub Private Sub lb_Click() End Sub Private Sub UserForm_Initialize() With lb .ColumnCount = 2 .ColumnWidths = "255, 400" End With End Sub
Register To Reply
Bookmarks