VBA code to let Excel "breath"?

[Jaymond Flurrie]

I have a code that works "perfectly". It writes 350 000 rows into a text file. I want to let user know what is happening so I use application.statusbar with a mod operation, like this:

For L = LBound(vCards, 1) + 1 To UBound(vCards, 1) 'Skip header row
            strCard = L & vbTab & vCards(L, 2) & vbTab & vCards(L, 3) & vbTab & vCards(L, 4) & vbTab & vCards(L, 5) & vbTab & vCards(L, 6) & vbTab & vCards(L, 7) & vbTab & vCards(L, 8) & vbTab & vCards(L, 9) & vbTab & vCards(L, 10) & vbTab & vCards(L, 10) & vbTab & vCards(L, 11) & vbTab & vCards(L, 12) & vbTab & vCards(L, 13)
            
            If L Mod 10000 = 0 Then
                Application.StatusBar = "Creating temporary textfile for uploading, " & L & " of " & UBound(vCards, 1) & " cards processed"
            End If
            
            Print #lProductFile, strCard
        Next L

The problem is that after a while Excel "chokes" and while it does what I want it to do, user gets a pretty clear signal that it crashed. What's the recommended way to let Excel catch it's breath so that even if the code would run slightly slower, I could keep user updated of the process instead of this legendary "The program is not responding"-status?

 

[wigi]

Before answering that question, please show us the entire code.
Why do you write line by line?

 

[Jaymond Flurrie]

Before answering that question, please show us the entire code.
Why do you write line by line?

How do I print the whole array into a txt-file at once?

Anyway, here:

Option Explicit


Sub DatabaseToTXT()
    
    Dim lCardFile As Long 'The text file handle
    Dim strCardFile As String 'The name of the text file
    Dim strCard As String 'One card
    Dim vCards As Variant 'The array of cards
    Dim L As Long 'Loop variable
    
    'Inform user of what we're doing
    Application.StatusBar = "Creating temporary textfile for uploading"
    
    'Save the card range to an array to speed up the code
    vCards = shtTemp.Range("A1").CurrentRegion
    
    'Name the temporary file
    strCardFile = ActiveWorkbook.Path & "\cards.txt"
    
    'Check if we have anything to upload
    If UBound(vCards, 1) < 2 Then
        MsgBox ("Nothing to upload")
    Else
        'Get a handle for the file
        lCardFile = FreeFile()
        
        'Open the file
        Open strCardFile For Output As lCardFile
        
        'Loop thru the cards
        For L = LBound(vCards, 1) + 1 To UBound(vCards, 1) 'Skip the header row
            'Compile info of the cards
            strCard = vCards(L, 2) & vbTab & vCards(L, 3) & vbTab & vCards(L, 4) & vbTab & vCards(L, 5) & vbTab & vCards(L, 6) & vbTab & vCards(L, 7) & vbTab & vCards(L, 8) & vbTab & vCards(L, 9) & vbTab & vCards(L, 10) & vbTab & vCards(L, 10) & vbTab & vCards(L, 11) & vbTab & vCards(L, 12) & vbTab & vCards(L, 13)
            
            'Inform users of progress
            If L Mod 10000 = 0 Then
                Application.StatusBar = "Creating temporary textfile for uploading, " & L & " of " & UBound(vCards, 1) & " cards processed"
            End If
            
            'Print the card to the text file
            Print #lCardFile, strCard
        Next L
    End If
    
    'Close the text file
    Close #lCardFile
    
End Sub

 

[shg]

Try adding DoEvents immediately after writing to the statusbar.

 

[Jaymond Flurrie]

Try adding DoEvents immediately after writing to the statusbar.

sub credits()
msgbox "Thank you for the answer, it worked immediately!"
msgbox "end case"
end sub

 

[shg]

Feel inclined to see if this works faster (completely untested)?

Sub DatabaseToTXT()
    Dim vCards      As Variant      ' array of cards
    Dim iFile       As Integer      ' file number
    Dim sFile       As String       ' output filename
    Dim sOut        As String       ' output string
    Dim iRow        As Long         ' outer loop variable
    Dim jRow        As Long         ' inner loop variable
    Dim nRow        As Long         ' number of rows

    Application.StatusBar = "Creating temporary textfile for uploading"
    vCards = shtTemp.Range("A1").CurrentRegion.Resize(, 13)
    sFile = ActiveWorkbook.Path & "\cards.txt"
    nRow = UBound(vCards, 1)

    If nRow < 2 Then
        MsgBox ("Nothing to upload")

    Else
        iFile = FreeFile()
        Open sFile For Output As iFile

        With WorksheetFunction
            For iRow = 2 To nRow Step 1000
                sOut = vbNullString
                For jRow = iRow To .Min(iRow + 999, nRow)
                    sOut = sOut & vbCrLf & Join(.Index(vCards, jRow, 0), vbTab) & vbCrLf
                Next jRow

                Print #iFile, Mid(sOut, 2)
                Application.StatusBar = "Output row " & jRow & " of " & nRow
                DoEvents
            Next iRow
        End With

        Close #iFile
        Application.StatusBar = False
    End If
End Sub

 

[wigi]

My suggestion:

Sub DatabaseToTXT_WIGI()

    Dim strCardFile As String
    Dim strCard As String
    Dim vCards
    Dim vCards_Concat
    Dim L As Long, M As Single

    With Range("A1").CurrentRegion
        With .Resize(, .Columns.Count - 2).Offset(, 2)
            vCards = .Value
            vCards_Concat = .Columns(1).Value
        End With
    End With

    strCardFile = ActiveWorkbook.Path & "\cards.txt"
    If Len(Dir(strCardFile)) Then Kill strCardFile

    If UBound(vCards) < 2 Then
        MsgBox "Nothing to upload"
    Else
        For L = 1 To UBound(vCards)
            strCard = ""
            For M = 1 To UBound(vCards, 2)
                strCard = strCard & vbTab & vCards(L, M)
            Next
            vCards_Concat(L, 1) = Mid(strCard, 2)            
        Next
        
        Open strCardFile For Output As #1
        Print #1, Join(Application.Transpose(vCards_Concat), vbCrLf)
        Close #1
    End If
End Sub

 

[shg]

Reckon it depends on how much data is in those 4.5 million cells ...

 

[wigi]

An improved suggestion:

Sub DatabaseToTXT_WIGI()

    Dim strCardFile As String
    Dim vCards
    Dim vCards_Concat
    Dim L As Long


    With Range("A1").CurrentRegion.Offset(1)
        With .Resize(, .Columns.Count - 2).Offset(, 2)
            vCards = .Value
            vCards_Concat = .Columns(1).Value
        End With
    End With


    strCardFile = ActiveWorkbook.Path & "\cards.txt"
    If Len(Dir(strCardFile)) Then Kill strCardFile


    If UBound(vCards) < 2 Then
        MsgBox "Nothing to upload"
    Else
        For L = 1 To UBound(vCards)
            vCards_Concat(L, 1) = Join(WorksheetFunction.Index(vCards, L, 0), vbTab)
        Next
        
        Open strCardFile For Output As #1
        Print #1, Join(Application.Transpose(vCards_Concat), vbCrLf)
        Close #1
    End If
End Sub

 

[Rick Rothstein]

'Compile info of the cards
strCard = vCards(L, 2) & vbTab & vCards(L, 3) & vbTab & vCards(L, 4) & vbTab & vCards(L, 5) & vbTab & vCards(L, 6) & vbTab & vCards(L, 7) & vbTab & vCards(L, 8) & vbTab & vCards(L, 9) & vbTab & vCards(L, 10) & vbTab & vCards(L, 10) & vbTab & vCards(L, 11) & vbTab & vCards(L, 12) & vbTab & vCards(L, 13)
'
'

I presume you meant to deliberately skip the data in Column 1, but did you really mean to repeat the data from Column 10 as shown in red above?