I am trying to write a code that will loop through 2 different arrays. The first loop works fine however when I get to the second loop the second array does not read the information form the first array. Can Anyone help me please. Please see code below.
Sub BackEndScanningProject()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For X = 1 To 13
Dim PathEntry$, W%
Dim sPath$
Dim FSO, MainFile As Object
Dim FileName As String
Dim FS, SubFldr, LittleFolder, MainFolder
If X = 1 Then SubFoldername = "C:\Any Old Folder\\Qtr 1 - 2002"
If X = 2 Then SubFoldername = "C:\Any Old Folder\\Qtr 2 - 2002"
If X = 3 Then SubFoldername = "C:\Any Old Folder\\Qtr 3 - 2002"
If X = 4 Then SubFoldername = "C:\Any Old Folder\\Qtr 4 - 2002"
If X = 5 Then SubFoldername = "C:\Any Old Folder\\Qtr 1 - 2003"
If X = 6 Then SubFoldername = "C:\Any Old Folder\\Qtr 2 - 2003"
If X = 7 Then SubFoldername = "C:\Any Old Folder\\Qtr 3 - 2003"
If X = 8 Then SubFoldername = "C:\Any Old Folder\\Qtr 4 - 2003"
If X = 9 Then SubFoldername = "C:\Any Old Folder\\Qtr 1 - 2004"
If X = 10 Then SubFoldername = "C:\Any Old Folder\\Qtr 2 - 2004"
If X = 11 Then SubFoldername = "C:\Any Old Folder\\Qtr 3 - 2004"
If X = 12 Then SubFoldername = "C:\Any Old Folder\\Qtr 4 - 2004"
If X = 13 Then SubFoldername = "C:\Any Old Folder\\Qtr 3_4 - 2001"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SubFldr = FS.GetFolder(SubFoldername)
Set MainFolder = SubFldr.SubFolders
ReDim Test(Z) As Variant
Dim SpongeBob As String
For Each LittleFolder In MainFolder
Z = Z + 1
ReDim Preserve Test(Z)
Test(Z) = LittleFolder
Next
For FolderPath = 1 To UBound(Test())
OP = Test(FolderPath)
Set FSO1 = CreateObject("Scripting.FileSystemObject")
Set g = FSO1.GetFolder(OP)
Set gc = g.SubFolders
Dim AnotherName() As Variant
For Each g1 In gc
V = V + 1
ReDim Preserve AnotherName(V)
AnotherName(V) = g1
Next
If V = Empty Then GoTo BoBo
For FolderPath1 = 1 To UBound(AnotherName)
PathName = AnotherName(FolderPath1)
Workbooks.Add
[A1] = "File Path"
[B1] = "Title / Keywords"
[C1] = "File Type"
[D1] = "File Size"
[E1] = "Date Created"
[f1] = "Date Last Accessed"
[g1] = "Date Last Modified"
Rows("1:1").Select
With Selection
.Font.Name = "Tahoma"
.Font.FontStyle = "Regular"
.Font.Size = 12
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
sPath$ = PathName
PathEntry = Dir(sPath & "\*.*", vbNormal + vbHidden)
FileName = sPath & "\" & PathEntry
W = 1
While Len(PathEntry)
If PathEntry <> "." And PathEntry <> ".." Then
If LCase(Mid(PathEntry, InStr(1, PathEntry, ".") + 1)) = "pdf" Then
W = W + 1
If W = "65536" Then
Sheets.Add
W = 1
[A1] = "File Path"
[B1] = "Title / Keywords"
[C1] = "File Type"
[D1] = "File Size"
[E1] = "Date Created"
[f1] = "Date Last Accessed"
[g1] = "Date Last Modified"
Rows("1:1").Select
With Selection
.Font.Name = "Tahoma"
.Font.FontStyle = "Regular"
.Font.Size = 12
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End If
Set MainFile = FSO.GetFile(FileName)
Cells(W, 1) = sPath
Cells(W, 2) = PdfTitle(sPath, PathEntry)
Cells(W, 3).Formula = MainFile.Type
Cells(W, 4).Formula = MainFile.Size
Cells(W, 5).Formula = MainFile.DateCreated
Cells(W, 6).Formula = MainFile.DateLastAccessed
Cells(W, 7).Formula = MainFile.DatelastModified
End If
PathEntry = Dir()
End If
Wend
Cells.Select
Columns.AutoFit
Bob = Mid(PathName, 31)
Bob = Replace(Bob, "\", " - ") & ".xls"
ActiveWorkbook.SaveAs "C\Folder Where I save the results\Excel Data Files" & "\" & Bob
ActiveWorkbook.Close
Next FolderPath1
BoBo:
Next FolderPath
Next X
End Sub
Private Function PdfTitle$(iPath$, iFile$)
With CreateObject("Shell.Application").Namespace(CStr(iPath))
PdfTitle = .GetDetailsOf(.ParseName(iFile), 10)
End With
Bookmarks