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?

 

[shg]

I think Transpose will have a problem with an array larger than 64k.

 

[wigi]

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

I agree. My latest code works fine with 100 rows (simple numbers lile the result of =ROW() in 13 columns), but the same code does not run for 350,000 rows * 13 columns.

 

[Jaymond Flurrie]

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

I got Type Mismatch at
sOut = sOut & vbCrLf & Join(.Index(vCards, jRow, 0), vbTab) & vbCrLf

 

[Jaymond Flurrie]

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

Got type mismatch at
Join(Application.Transpose(vCards_Concat), vbCrLf)

 

[Jaymond Flurrie]

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

Got type mismatch at
vCards_Concat(L, 1) = Join(WorksheetFunction.Index(vCards, L, 0), vbTab)

 

[shg]

Index doesn't work with arrays larger than 64k either


Hang on a sec ...

 

[Jaymond Flurrie]

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?

Ha. That's the reason why MySQL complains (the reason for whole function here is to compile the txt-file to LOAD INFILE to MySQL database).

 

[Jaymond Flurrie]

Just to give some idea, my function takes 16,13086 seconds to complete. Naturally it depends on the computer too, I have a Core2Duo e6300 processor, Windows 7, 4GB DDR2 memory and Excel 2007.

 

[wigi]

Obviously, a different approach but much simpler, would be:

Sub DatabaseToTXT_WIGI()

    Dim strCardFile As String
    strCardFile = ActiveWorkbook.Path & "\cards.txt"
    If Len(Dir(strCardFile)) Then Kill strCardFile
    
    With Range("A1").CurrentRegion.Offset(1)
        With .Resize(, .Columns.Count - 2).Offset(, 2)
            .Copy Workbooks.Add.Worksheets(1)
        End With
    End With
    
    With ActiveWorkbook
        .SaveAs strCardFile, xlText
        .Close 0
    End With
    
End Sub

 

[Jaymond Flurrie]

Obviously, a different approach but much simpler, would be:

Sub DatabaseToTXT_WIGI()

    Dim strCardFile As String
    strCardFile = ActiveWorkbook.Path & "\cards.txt"
    If Len(Dir(strCardFile)) Then Kill strCardFile
    
    With Range("A1").CurrentRegion.Offset(1)
        With .Resize(, .Columns.Count - 2).Offset(, 2)
            .Copy Workbooks.Add.Worksheets(1)
        End With
    End With
    
    With ActiveWorkbook
        .SaveAs strCardFile, xlText
        .Close 0
    End With
    
End Sub

Pretty smart idea, got to admit that!

Anyway, copy method of range class failed at
.Copy Workbooks.Add.Worksheets(1)