CODEWITHSUNDEEP
vbaexcel
Vince Noir
Vince Noir

Reputation: 171

VBA Do Until loop sometimes fails

I'm writing some pretty basic Excel VBA Macros to do with splitting and merging large workbooks on their worksheets. I've got it mostly ironed out, but I have a failure occuring intermittently (about 1 time in 10) that I can't seem to reliably reproduce, let alone fix.

There are 205 or so single-sheeted workbooks in the folder I'm interested in, and the macro uses Dir() to cycle through them, ending when it reaches an empty filename. Except sometimes it doesn't.

It will occasionally just stop at a random point of going through these files. I've seen it happen between 60-190 imports, and it just stops the execution at that point with no error or warning. The rest of the code after the Do Until Loop doesn't get executed.

Has anyone run across something similar? Is it a memory issue within excel? I'm losing my mind here. Adding a timer to the loop to slow it down has not helped. There are no open files within the folder I'm merging from. Suppressing the alerts that popup during the merging processes is not the issue.

Here's the code for the loop:

    strFilename = Dir(myPath & "\*.xlsx", vbNormal)

    If Len(strFilename) = 0 Then Exit Sub

    Do Until strFilename = ""
        Set wbSrc = Workbooks.Open(fileName:=myPath & "\" & strFilename, UpdateLinks:=False)
        Set wsSrc = wbSrc.Worksheets(1)
        wsSrc.Copy after:=wbDst.Worksheets(wbDst.Worksheets.Count)
        wbSrc.Close False
        strFilename = Dir()
    Loop

Upvotes: 3

Views: 1686

Answers (1)

Vince Noir
Vince Noir

Reputation: 171

Massive thanks to Rory's comment for the shift-key hint (and all the other help too, of course). There were no macros running that were using the Shift key but occasionally as I alt-tabbed out, I'd use alt-shift-tab or some other combination using shift and break it due to Excel's "No shift when opening" security rule.

The documentation on the microsoft support page has a resolution for this issue, involving detecting when the shift key is held and running another loop inside the Do Until that prevents open from being called until it's released.

Final relevant code:

'Declare API
Declare Function GetKeyState Lib "User32" _
(ByVal vKey As Integer) As Integer
Const SHIFT_KEY = 16

Function ShiftPressed() As Boolean
'Returns True if shift key is pressed
    ShiftPressed = GetKeyState(SHIFT_KEY) < 0
End Function

...

    Do Until strFilename = ""
        Do While ShiftPressed()
            DoEvents
        Loop
        Set wbSrc = Workbooks.Open(fileName:=myPath & "\" & strFilename, UpdateLinks:=False)
        Set wsSrc = wbSrc.Worksheets(1)
        wsSrc.Copy after:=wbDst.Worksheets(wbDst.Worksheets.Count)
        wbSrc.Close False
        strFilename = Dir()
    Loop

Upvotes: 7

Related Questions