DIR function doesn't iterate

[bcpelkey]

Hi all,

When I step-through my code below, it always opens the first file in the directory "C:\Pyramid Files", but when it comes back to the Pyramid Files sub after fully processing the first file via various other subs, the VB Editor apparently doesn't like something about this line: StrFile = Dir(), since it quits after "snapping-back" to the previous sub Initialize(). I have also tried StrFile = Dir, but that doesn't work either. I did Dim Strfile in the General Declarations. When I set Watches for Dir and Dir(), I get the value "Invalid procedure call or argument" for both, as if the directory function lost the value. I can't determine why this is happening. Can you see what I am missing?

Dim WSM As Worksheet, WSB As Worksheet, WS1 As Worksheet, [U]StrFile As String[/U], StrDirectory As String, ClientCode As String 
Dim Filename As String, LastRowb As Long, LastColB As Integer, LastRow1 As Integer, NextRowC As Integer, x As Integer, y As Integer 
 
Public Sub Initialize() 
    Set WSM = ThisWorkbook.Worksheets("Macro") 
    Set WS1 = ThisWorkbook.Worksheets("Sheet1") 
     
     'Create a directory to store individual client files
    On Error Resume Next 
    MkDir "c:\Client Code Files" 
   
    Application.ScreenUpdating = False 
     
    PyramidFiles 
    Application.ScreenUpdating = True 
End Sub 
 
Sub PyramidFiles() 
     
    StrDirectory = "C:\Pyramid Files" 
    StrFile = Dir("C:\Pyramid Files\HPES_Asset_Recon*") 
     
    Dim sh As Worksheet, flg As Boolean 
     
    Do While StrFile <> "" 
        For Each sh In Worksheets 
            If sh.Name = "Pyramid File" Then flg = True: Exit For 
        Next 
         
        If flg = True Then 
            WSB.Delete 
            Filename = StrDirectory + "\" + StrFile 
            OpenPyramidFiles 
             
        Else:  Filename = StrDirectory + "\" + StrFile 
            OpenPyramidFiles 
        End If 
         
        StrFile = Dir() 'Note: The script had a problem with this line.  It "snapped-back" to the Initialize sub and quit.
         
    Loop 
     
End Sub

 

[Norie]

What happens in the OpenPyramidFiles sub?

 

[bcpelkey]

The OpenPyramidFiles sub does just that:


[CODEPublic Sub OpenPyramidFiles()

Workbooks.Open Filename
ActiveSheet.Name = "Pyramid File"
Sheets("Pyramid File").Copy After:=Workbooks("Pyramid Extraction Macro.xlsm").Sheets("Clients With Leased Assets")
Fname = Mid(Filename, 18, 47)

Workbooks(Fname).Close SaveChanges:=False
Set WSB = Worksheets("Pyramid File")
'WSB.Rows(2).Delete
LastRowb = WSB.Cells(Rows.Count, 1).End(xlUp).Row
LastColB = 33

WSB.Range("AH1").Value = "Customer Code"

PrepareSheet1 'UniqueCustCodes

End Sub][/CODE]

 

[Norie]

What other subs are called?

The reason I ask is because there could be something in the other subs/functions that's affecting Dir.

For example, change StrFile in some way.

By the way, why have you declared all the variables outside subs?

That means that they are available in all the subs in the module, which kind of increases the chance of errors.

 

[bcpelkey]

Hi Norie,

StrFile is only referred to in the 1 sub. Below is my total script at this point:

[CODEDim WSM As Worksheet, WSB As Worksheet, WS1 As Worksheet, StrFile As String, StrDirectory As String, ClientCode As String
Dim Filename As String, LastRowb As Long, LastColB As Integer, LastRow1 As Integer, NextRowC As Integer, x As Integer, y As Integer
Public Sub Initialize()
Set WSM = ThisWorkbook.Worksheets("Macro")
Set WS1 = ThisWorkbook.Worksheets("Sheet1")

'Create a directory to store individual client files
On Error Resume Next
MkDir "c:\Client Code Files"
Application.ScreenUpdating = False
PyramidFiles
Application.ScreenUpdating = True
End Sub
Sub PyramidFiles()

StrDirectory = "C:\Pyramid Files"
StrFile = Dir("C:\Pyramid Files\HPES_Asset_Recon*")

Dim sh As Worksheet, flg As Boolean

Do While StrFile <> ""
For Each sh In Worksheets
If sh.Name = "Pyramid File" Then flg = True: Exit For
Next

If flg = True Then
WSB.Delete
Filename = StrDirectory + "\" + StrFile
OpenPyramidFiles

Else: Filename = StrDirectory + "\" + StrFile
OpenPyramidFiles
End If
StrFile = Dir() 'Note: The script had a problem with this line. It "snapped-back" to the Initial sub and quit.
'Quit.
Loop
End Sub
Public Sub OpenPyramidFiles()

Workbooks.Open Filename
ActiveSheet.Name = "Pyramid File"
Sheets("Pyramid File").Copy After:=Workbooks("Pyramid Extraction Macro.xlsm").Sheets("Clients With Leased Assets")
Fname = Mid(Filename, 18, 47)

Workbooks(Fname).Close SaveChanges:=False
Set WSB = Worksheets("Pyramid File")
'WSB.Rows(2).Delete
LastRowb = WSB.Cells(Rows.Count, 1).End(xlUp).Row
LastColB = 33

WSB.Range("AH1").Value = "Customer Code"

PrepareSheet1 'UniqueCustCodes

End Sub
Public Sub PrepareSheet1()
WS1.Range("A2:A500").ClearContents
Dim ColE As Range
Set ColE = WSB.Range(Cells(2, 5).Address, Cells(LastRowb, 5).Address)
'Copy Unique Pyramid File Customer Codes to Sheet1
ColE.AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Sheets("Sheet1").Range("A2"), _
Unique:=True
Sheets("Sheet1").Range("A1").Value = "Customer Code"
LastRow1 = WS1.Cells(Rows.Count, 1).End(xlUp).Row
'Sort Range
Dim CCrange As Range
Set CCrange = WS1.Range(Cells(2, 1).Address, Cells(LastRow1, 2).Address)
'Sort Key1
Dim A1 As Range
Set A1 = WS1.Range("A1")
'Sort Key2
Dim B1 As Range
Set B1 = WS1.Range("B1")
'Sort by Client Code, then by Customer Code
CCrange.Sort Key1:=B1, Order1:=xlDescending, Key2:=A1, Order1:=xlAscending, Header:=xlYes
'A value at the top of the list shouldn't be there, thus the deletion
Sheets("Sheet1").Rows(2).Delete
LastRow1 = WS1.Cells(Rows.Count, 1).End(xlUp).Row
ProcessCC
End Sub
Public Sub ProcessCC()
WS1.Activate
Range("B1").Activate

'This code Requires Sheet1 to be the ActiveSheet to evaluate the Do Until properly
Do Until ActiveCell.Offset(1, 0) = ""
ActiveCell.Offset(1, 0).Activate
ClientCode = ActiveCell.Value
CustCode = ActiveCell.Offset(0, -1).Value
WSB.Range("AH2").Value = CustCode

Sheets.Add.Name = ClientCode

For y = 1 To 1
Set WSC = Sheets(ClientCode)
Next y
NextRowC = 1
AdvFilter

Do While ActiveCell.Offset(1, 0) = ClientCode
ActiveCell.Offset(1, 0).Activate
ClientCode = ActiveCell.Value
CustCode = ActiveCell.Offset(0, -1).Value
WSB.Range("AH2").Value = CustCode
LastRowC = WSC.Cells(Rows.Count, 1).End(xlUp).Row
NextRowC = LastRowC + 1
AdvFilter
Loop

'When processing of a Client Code concludes, delete redundant header lines
'Sheets(ClientCode).Activate

'WSC.Activate
'DelHdrs

'When processing of a Client Code concludes, save the worksheet to a workbook & close it.
'Either the information is appended to an existing file or a new file is created & populated
CCfile = "C:\Client Code Files\" & ClientCode & ".xlsx"

If Dir(CCfile) = "" Then
Dim wb As Workbook
Worksheets(ClientCode).Copy
Set wb = ActiveWorkbook
wb.SaveAs "C:\Client Code Files\" & ClientCode
wb.Close
Else
'Open existing file
Dim WBD As Workbook
Set WBD = Workbooks.Open("C:\Client Code Files\" & ClientCode)

Set WSD = WBD.Worksheets(1)
Dim LastRowD As Long, NextRowD As Long
LastRowD = WSD.Cells(Rows.Count, 1).End(xlUp).Row
NextRowD = LastRowD + 1

'Set range of Client Code Worksheet
Dim rngData As Range
Set rngData = WSC.UsedRange


'Append WSC data to data in existing file, then close & save the file
rngData.Copy Destination:=WSD.Range("A" & NextRowD)
WBD.Close True
End If

'Delete Client Code Worksheet
Application.DisplayAlerts = False
WSC.Delete
Application.DisplayAlerts = True

Sheets("Sheet1").Activate

Loop
End Sub
Public Sub AdvFilter()

'Input Range: The Entire Pyramid File
Dim IRange As Range
Set IRange = WSB.Range(Cells(1, 1).Address, Cells(LastRowb, LastColB).Address)
'Redefine the Output Range
Dim ORange As Range
Set ORange = Sheets(ClientCode).Range("A" & NextRowC)
Dim CRange As Range
Set CRange = WSB.Range("AH1:AH2")
IRange.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=CRange, _
CopyToRange:=ORange, _
Unique:=False
Sheets("Sheet1").Activate
End Sub][/CODE]

 

[Norie]

If it's only used in one sub declare it in that sub.

By the way, it's probably a good idea to remove this, it could be hiding errors.

    On Error Resume Next

 

[bcpelkey]

If it's only used in one sub declare it in that sub.

By the way, it's probably a good idea to remove this, it could be hiding errors.

    On Error Resume Next

Hi Norie, thanks for your help and suggestions.

I fixed the script by installing a file open counter and a related patch to "refresh" the Excel VBA Dir () function. Otherwise, it returned a null string, i.e. "". Other changes I made first that didn't solve the problem included changing the Sub to a Public Sub and I dimmed StrFile at the local level (within the only sub it is used in).

Public Sub PyramidFiles() 
     
    Dim StrFile As String 
    Dim StrDirectory As String 
    StrDirectory = "C:\Pyramid Files" 
    StrFile = Dir("C:\Pyramid Files\HPES_Asset_Recon*") 
     
    Dim sh As Worksheet, flg As Boolean 
     
    Do While StrFile <> "" 
        For Each sh In Worksheets 
            If sh.Name = "Pyramid File" Then flg = True: Exit For 
        Next 
         
        If flg = True Then 
            Application.DisplayAlerts = False 
            WSB.Delete 
            Application.DisplayAlerts = True 
            Filename = StrDirectory + "\" + StrFile 
            opencount = opencount + 1 
            OpenPyramidFiles 
             
        Else:  Filename = StrDirectory + "\" + StrFile 
            opencount = opencount + 1 
            OpenPyramidFiles 
        End If 
         
         [B]'This is a patch to refresh/enable Dir iterations.  Otherwise, StrFile evaluates to "".
         
        StrFile = Dir("C:\Pyramid Files\HPES_Asset_Recon*") 
         
        For Z = 1 To opencount 
            StrFile = Dir() 
        Next Z 
[/B]        
    Loop 
     
End Sub