Text To Columns Macro (to avoid out of memory error)

[dougf]

I am trying to convert cells (all in column D) which are separated by "~" into columns. Unfortunately, running the text to columns command on several rows at a time can cause Excel to panic with an out of memory error (error #7 etc.).

The file is ~100mb and contains 500k-700k rows (I have 4GB of RAM so I know this is more a limit of Excel's 2GB RAM constraint).

Can you please help me write a macro to text to column convert each cell in column D?

I tried a macro which started with a for loop, and called the function for each cell individually, but even this led to an out of memory exception after 156,000 rows (although the same macro worked fine on a similar sheet with 700,000 rows).

Are there any other ways of clearing the Excel buffer/temporary space during the function calls to avoid causing Excel to crash?

Thanks!

 

[PCL]

Try next code.
It assumes there is enought columns free after column D

Sub Split_Data()
Dim LASTROW As Long
Dim I As Long, J As Long
Dim LLength As Long
Dim MySTRING As String
Dim MyCHAR As String
Dim MyRG As Range
Dim F As String
Dim NbPART As String
Dim POS  As Long
Dim A
    Application.ScreenUpdating = False       '   WITHOUT  REFRESH SCREEN
    MyCHAR = "~"
    LASTROW = Range("D" & Rows.Count).End(xlUp).Row
    For I = 1 To LASTROW
        F = Cells(I, "D")
        NbPART = Len(F) - Len(Replace(F, MyCHAR, "")) + 1
        For J = 1 To NbPART - 1
            POS = InStr(F, MyCHAR)
            Cells(I, "D").Offset(0, J) = Left(F, POS - 1)
            F = Right(F, Len(F) - POS)
        Next J
        Cells(I, "D").Offset(0, J) = Right(F, Len(F) - 1)
    Next I
    Application.ScreenUpdating = True       '   WITH  REFRESH SCREEN
End Sub

 

[Legacy 14611]

Sub txt_to_col()
Dim n As Long, I As Long, J As Long, c(), A, y
n = Cells(Rows.Count, "d").End(xlUp).Row
ReDim c(1 To n, 1 To 1)
A = Range("D1:D" & n)
For I = 1 To n
    y = Split(Cells(I, "d"), "~", -1)
If UBound(y) > s Then s = UBound(y)
If s > UBound(c, 2) - 1 Then ReDim Preserve c(1 To n, 1 To s + 1)
For J = 0 To UBound(y)
    On Error Resume Next
    c(I, J + 1) = y(J)
    On Error GoTo 0
Next J, I
Range("F1").Resize(n, UBound(c, 2)) = c
End Sub

 

[Legacy 14611]

or, if you want it to run faster

Sub txt_to_col()
Dim n As Long, i As Long, j As Long, c(), a, y
n = Cells(Rows.Count, "d").End(xlUp).Row
ReDim c(1 To n, 1 To 1)
a = Range("D1:D" & n)
For i = 1 To n
    y = Split(a(i,1), "~", -1)
If UBound(y) > s Then s = UBound(y)
If s > UBound(c, 2) - 1 Then ReDim Preserve c(1 To n, 1 To s + 1)
For j = 0 To UBound(y)
    On Error Resume Next
    c(i, j + 1) = y(j)
    On Error GoTo 0
Next j, i
Erase a
Range("F1").Resize(n, UBound(c, 2)) = c
End Sub

 

[dougf]

or, if you want it to run faster

Sub txt_to_col()
Dim n As Long, i As Long, j As Long, c(), a, y
n = Cells(Rows.Count, "d").End(xlUp).Row
ReDim c(1 To n, 1 To 1)
a = Range("D1:D" & n)
For i = 1 To n
    y = Split(a(i,1), "~", -1)
If UBound(y) > s Then s = UBound(y)
If s > UBound(c, 2) - 1 Then ReDim Preserve c(1 To n, 1 To s + 1)
For j = 0 To UBound(y)
    On Error Resume Next
    c(i, j + 1) = y(j)
    On Error GoTo 0
Next j, i
Erase a
Range("F1").Resize(n, UBound(c, 2)) = c
End Sub

Hi Rugila,

Unfortunately this code immediately leads to an Out Of Memory #7 exception. The debugger highlights "ReDim Preserve c(1 To n, 1 To s + 1)"

Are there any alternatives?


PCL, the line "Cells(I, "D").Offset(0, J) = Right(F, Len(F) - 1)" is an invalid procedure call.


Thanks!!

 

[VoG]

Are there filled columns to the right of column D?

 

[dougf]

Are there filled columns to the right of column D?

VoG,

All columns after D are currently empty.

 

[phxsportz]

Hmm... You have 700,000 rows of data ?

I thought Excel had a row limitation of 65,536 rows ?? Could this be the problem ?>

 

[dougf]

Hmm... You have 700,000 rows of data ?

I thought Excel had a row limitation of 65,536 rows ?? Could this be the problem ?>

Nope. 1 million rows in Excel 2007 (plus 16k columns).

 

[phxsportz]

Ahhh... gotcha... just a poor slob here with 2003 lol