Looping through text files - need some optimization help

A

Asala42

Well-known Member
Joined
Feb 26, 2002
Messages
2,318
Let me tell you what I'm basically trying to do.

I have a folder with a lot of text files. 3000 txt files, each about 10MB. What I"m trying to do is extract a few pieces of data from each of these and build those into a single table. In the end I'd expect the table to be about 5 columns/10K records total - just to give you a ballpark.

I've written a macro, posted below, that covers the basic mechanics of this. In summary it performs the following steps:
1) Loops through each text file in a designated folder. One at a time it:
2) Opens the text file.
3) Copies the data to a designated worksheet
4) Enters, Copies, and then clears formulas that will identify the records we want.
5) Autofilter/copies the data we want and appends it to a data table on another sheet.
6) Clears the data on the original data sheet
7) Closes the text file
8) repeat until out of text files.

The macro seems to work okay but only when running it over a small number of text files. It runs reasonably well over 5 text files but it gets progressively more sluggish as I try to run it over more files.

With 5 text files to loop through the code averages about 17 seconds per file.
With 25 text files the code averaged about 2:30 per file.
With 100 text files the code took about 7 hours and crashed excel in the process.

So I figure I must have some fatal flaw in my code. Here is the code I'm using - I'd appreciate any optimization ideas.
Code: 
Sub LoopThroughText()

    Dim path      As String
    Dim ThisWB    As String
    Dim Filename  As String
    Dim Wkb       As Workbook
    Dim lastR     As Long
    Dim i         As Long
 
    Application.EnableEvents = False
    Application.ScreenUpdating = False

    ThisWB = ActiveWorkbook.Name
    path = "P:\Reports\call data\DumpingGround"
    Filename = Dir(path & "\*.txt", vbNormal)
    If Len(Filename) = 0 Then Exit Sub
    Do Until Filename = vbNullString
        If Not Filename = ThisWB Then
            Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
                Cells.Select
                Selection.Copy
                                
                Windows(ThisWB).Activate
                Worksheets("Crunch").Activate
                
                lastR = Range("A" & Rows.Count).End(xlUp).Row
                Range("A1").PasteSpecial

                Application.CutCopyMode = False
                
            Columns("A:A").Select
                Selection.Replace What:="=--", Replacement:="", LookAt:=xlPart, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                ReplaceFormat:=False
                  
            Columns("B:AI").Select
            Selection.ClearContents
                  
            Range("B1").Value = "Catch"
            Range("C1").Value = "Number"
            Range("D1").Value = "From"
            Range("E1").Value = "From2"
            Range("F1").Value = "To"
            Range("G1").Value = "Date"
            Range("H1").Value = "Flag"
            
            Range("B2").Formula = "=IF(OR(LEFT(A2,14)=""Invite SIP:248"",AND(B1=1,LEFT(A2,10)<>""Supported:"")),1,0)"
            Range("C2").Formula = "=IF(LEFT(A2,11)=""Invite sip:"",MID(A2,12,FIND(""@"",A2)-12),IF(B2=1,C1,""""))"
            Range("D2").Formula = "=IF(LEFT(A2,5)=""From:"",MID(A2,6,FIND(""<"",A2)-6),IF(B2=1,D1,""""))"
            Range("E2").Formula = "=IF(LEFT(A2,5)=""From:"",MID(A2,FIND(""sip:"",A2)+4,FIND(""@"",A2)-FIND(""sip:"",A2)-4),IF(B2=1,E1,""""))"
            Range("F2").Formula = "=IF(LEFT(A2,9)=""To: <sip:"",MID(A2,10,FIND(""@"",A2)-10),IF(B2=1,F1,""""))"
            Range("G2").Formula = "=IF(LEFT(A2,5)=""Date:"",MID(A2,FIND("","",A2)+2,FIND("" GMT"",A2)-FIND("","",A2)-2)+0,IF(B2=1,G1,""""))"
            Range("H2").Formula = "=1*OR(ISERROR(B2),AND(B2=1,B3=0))"
            
            Range("B2:H2").Copy
            Range(Cells(2, 2), Cells(Range("A200000").End(xlUp).Row, 8)).PasteSpecial (xlPasteFormulas)
            
            Range(Cells(1, 2), Cells(Range("A200000").End(xlUp).Row, 8)).Copy
            Range(Cells(1, 2), Cells(Range("A200000").End(xlUp).Row, 8)).PasteSpecial (xlPasteValues)
            
            Range("H1").Select
            Selection.AutoFilter
  
            ActiveSheet.Range("H1").CurrentRegion.AutoFilter Field:=8, Criteria1:="=1"
            
            If Range("A300000").End(xlUp).Row > 1 Then
            
                Range(Cells(2, 2), Cells(Range("A200000").End(xlUp).Row, 8)).Select
                Selection.Copy
            
                Sheets("EndTable").Activate
                Range("A" & Range("A200000").End(xlUp).Row + 1).PasteSpecial (xlPasteValues)
                                    
                Sheets("Crunch").Activate
                Range("H1").Select
                Selection.AutoFilter
            
            End If
            
            Range("A1").Copy
            
            Application.ScreenUpdating = True
            
            Sheets("EndTable").Activate
            Range("I" & Range("I200000").End(xlUp).Row + 1).PasteSpecial (xlPasteValues)
            Range("J" & Range("J200000").End(xlUp).Row + 1).Formula = "=now()"
            Range("J" & Range("J200000").End(xlUp).Row).Copy
            Range("J" & Range("J200000").End(xlUp).Row).PasteSpecial (xlPasteValues)
            
            Application.ScreenUpdating = False
            
            Sheets("Crunch").Activate
            Columns("A:AZ").Select
            Selection.ClearContents
              
            Wkb.Close False
        End If
        Filename = Dir()
    Loop
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    MsgBox "Done"

End Sub
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
Sort by date Sort by votes
I dodn't know if this will help the memory leak, but you could eliminate all of the selecting:

Code: 
Sub LoopThroughText()
  Dim wksCrunch     As Worksheet
  Dim wksEndTbl     As Worksheet

  Dim sPath         As String
  Dim sFile         As String

  Set wksCrunch = ThisWorkbook.Worksheets("Crunch")
  Set wksEndTbl = ThisWorkbook.Worksheets("EndTable")

  sPath = "P:\Reports\call data\DumpingGround\"
  sFile = Dir(sPath & "*.txt", vbNormal)

  Application.EnableEvents = False

  Do While Len(sFile)
    With Workbooks.Open(Filename:=sPath & sFile)
      ActiveSheet.Cells.Copy

      With wksCrunch
        .Range("A1").PasteSpecial
        .Range("A:A").Replace What:="=--", Replacement:="", LookAt:=xlPart
        .Range("B:AI").ClearContents

        .Range("B1:H1").Value = Array("Catch", "Number", "From", "From2", "To", "Date", "Flag")
        .Range("B2").Formula = "=IF(OR(LEFT(A2,14)=""Invite SIP:248"",AND(B1=1,LEFT(A2,10)<>""Supported:"")),1,0)"
        .Range("C2").Formula = "=IF(LEFT(A2,11)=""Invite sip:"",MID(A2,12,FIND(""@"",A2)-12),IF(B2=1,C1,""""))"
        .Range("D2").Formula = "=IF(LEFT(A2,5)=""From:"",MID(A2,6,FIND(""<"",A2)-6),IF(B2=1,D1,""""))"
        .Range("E2").Formula = "=IF(LEFT(A2,5)=""From:"",MID(A2,FIND(""sip:"",A2)+4,FIND(""@"",A2)-FIND(""sip:"",A2)-4),IF(B2=1,E1,""""))"
        .Range("F2").Formula = "=IF(LEFT(A2,9)=""To:  1 Then"

        wksEndTbl.Cells(Rows.Count, "A").End(xlUp)(2).Value = _
        .Range("B2", .Cells(.Cells(Rows.Count, "A").End(xlUp).Row, "H")).Value

        .Range("H1").AutoFilter
        .Range("A1").Copy

        With wksEndTbl
          .Cells(Rows.Count, "I").End(xlUp)(2).PasteSpecial Paste:=xlPasteValues
          .Cells(Rows.Count, "J").End(xlUp)(2).Value = Now
        End With

        .Columns("A:AZ").ClearContents
      End With

      .Close SaveChanges:=False
    End With
    sFile = Dir()
  Loop

  Application.EnableEvents = True
  MsgBox "Done"
End Sub

Some of the code looks sketchy:

Code: 
        .Range("F2").Formula = "=IF(LEFT(A2,9)=""To:  1 Then"

I don't think that's a valid formula.

Code: 
        .Range("H1").AutoFilter

Why autofilter without setting a filter?

Does Excel's memory usage keep increasing as you run? You might try saving the workbook after each loop iteration. If that doesn't fix it, you could automate the process from another workbook (I assume this code is running in the workbook that is receiving the consolidation). Create a list of files first, then consolidate one (or a few) at a time, closing and reopening the workbook.
 
Upvote 0
Thanks for the reply Shg.

I think I lost some code during the copy/paste. The missing code is visible in a "reply with quote" on the original post. What's missing is a couple more formulas, copying down and clearing those formulas, adding a filter. I have no idea posting that code on this board is behaving that way.

I'll try modifying based on your comments.
 
Last edited:
Upvote 0
Just wanted to give an update.

I have a solution but it's a bit unorthodox and silly. In the end I made a PowerPoint macro (of all things). It didn't have to be PowerPoint, I just wanted an outside application that could repeatedly Open the excel file, execute the code, then close it on a calculated loop. Weirdest thing I've tried with code but it worked great.

I'll post the code in case anyone's curious.

In a PowerPoint file.
Code: 
Sub test()

Dim xlApp As Object
Dim xlWorkBook As Object
Dim i As Long

For i = 1 To 270
Set xlApp = CreateObject("Excel.Application")

xlApp.Visible = True
Set xlWorkBook = xlApp.Workbooks.Open("P:\Reports\testDatapull.xlsm", True, False)

xlApp.Run "Module1.LoopThroughText"

Do While xlWorkBook.sheets(1).Range("Q1").Value <> "Done"
     waitTime = 15
     Start = Timer
     While Timer < Start + waitTime
         DoEvents
     Wend
Loop

xlWorkBook.Close
xlApp.Quit

Set xlApp = Nothing
Set xlWorkBook = Nothing

Next i

End Sub


The macro called in Excel
Code: 
Sub LoopThroughText()
    Application.DisplayAlerts = True
    Worksheets("Sheet2").Range("Q1").Value = ""
    
    Dim path      As String
    Dim ThisWB    As String
    Dim Filename  As String
    Dim Wkb       As Workbook
    Dim lastR     As Long
    Dim i         As Long
    Dim j         As Long
    Dim Endrow    As Long
     
    Application.EnableEvents = False
    'Application.ScreenUpdating = False

    ThisWB = ActiveWorkbook.Name
    path = "P:\SalaReports\cisco call data\DumpingGround"
    Endrow = Worksheets("Sheet2").Range("A300000").End(xlUp).Row

    
    For i = Endrow To (Endrow - 4) Step -1
        Worksheets("Sheet2").Activate
        Filename = Dir(path & "\" & Cells(i, 1).Text, vbNormal)
               
        If Len(Filename) = 0 Then Exit Sub
        If Range("E1").Value = 0 Then Exit Sub
        
        Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
        
        Range(Cells(1, 1), Cells(Range("A300000").End(xlUp).Row, 1)).Copy
                                
                Windows(ThisWB).Activate
                Worksheets("Crunch").Activate
                
                lastR = Range("A" & Rows.Count).End(xlUp).Row
                Range("A1").PasteSpecial
    
                Application.CutCopyMode = False
    
    
        With Worksheets("Crunch")
            
                .Range("A:A").Replace What:="=--", Replacement:="", LookAt:=xlPart
                .Range("B:AI").ClearContents
                .Range("B1:H1").Value = Array("Catch", "Number", "From", "From2", "To", "Date", "Flag")
            
                .Range("B2").Formula = "=IF(OR(LEFT(A2,14)=""Invite SIP:248"",AND(B1=1,LEFT(A2,10)<>""Supported:"")),1,0)"
                .Range("C2").Formula = "=IF(LEFT(A2,11)=""Invite sip:"",MID(A2,12,FIND(""@"",A2)-12),IF(B2=1,C1,""""))"
                .Range("D2").Formula = "=IF(LEFT(A2,5)=""From:"",MID(A2,6,FIND(""<"",A2)-6),IF(B2=1,D1,""""))"
                .Range("E2").Formula = "=IF(LEFT(A2,5)=""From:"",MID(A2,FIND(""sip:"",A2)+4,FIND(""@"",A2)-FIND(""sip:"",A2)-4),IF(B2=1,E1,""""))"
                .Range("F2").Formula = "=IF(LEFT(A2,9)=""To: sip:"",MID(A2,10,FIND("" @ "",A2)-10),IF(B2=1,F1,""""))"
                .Range("G2").Formula = "=IF(LEFT(A2,5)=""Date:"",MID(A2,FIND("","",A2)+2,FIND("" GMT"",A2)-FIND("","",A2)-2)+0,IF(B2=1,G1,""""))"
                .Range("H2").Formula = "=1*OR(ISERROR(B2),AND(B2=1,B3=0))"
        End With

            Range("B2:H2").Copy
            Range(Cells(2, 2), Cells(Range("A200000").End(xlUp).Row, 8)).PasteSpecial (xlPasteFormulas)
            
            Range(Cells(1, 2), Cells(Range("A200000").End(xlUp).Row, 8)).Copy
            Range(Cells(1, 2), Cells(Range("A200000").End(xlUp).Row, 8)).PasteSpecial (xlPasteValues)
            
            Range("H1").Select
            Selection.AutoFilter
  
            ActiveSheet.Range("H1").CurrentRegion.AutoFilter Field:=8, Criteria1:="=1"
            
            If Range("A300000").End(xlUp).Row > 1 Then
            
                Range(Cells(2, 2), Cells(Range("A200000").End(xlUp).Row, 8)).Copy
                            
                Sheets("EndTable").Activate
                Range("A" & Range("A200000").End(xlUp).Row + 1).PasteSpecial (xlPasteValues)
                                    
                Sheets("Crunch").Activate
                Range("H1").Select
                Selection.AutoFilter
            
            End If
    
            Range("A1").Copy
            
            Sheets("EndTable").Activate
            Range("I" & Range("I200000").End(xlUp).Row + 1).PasteSpecial (xlPasteValues)
            Range("J" & Range("I200000").End(xlUp).Row).Value = Now()
            Range("K" & Range("I200000").End(xlUp).Row).Value = Filename
            
            Sheets("Crunch").Activate
            Cells.Delete
            ActiveWorkbook.Save
            
            Worksheets("Sheet2").Range("A" & i).ClearContents
                      
            Wkb.Close True
    
    Next i
            Sheets("Crunch").Activate
            Cells.Delete
            ActiveWorkbook.Save
    
    Worksheets("Sheet2").Range("Q1").Value = "Done"
    Application.DisplayAlerts = False

End Sub

As an aside, I believe the missing code from my initial post was from < > symbols that I happened to have in my formulas.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question
Replace different text/strings in multiple files in one folder
Replies
1
Views
318
Peter_SSs
Peter_SSs
I
  • Question
Current Code taking 10 Hours to run. Need Help to Optimize
Replies
5
Views
290
ItalianPlatinum
I
I
  • Solved
Set value for range being copied over with VBA
2
Replies
14
Views
252
ItalianPlatinum
I
The Ruff Report
  • Solved
VBA - replace a character in a range to save
Replies
5
Views
202
RobP
R
R
  • Question
Loop through Range and Force Formula Calculation
Replies
0
Views
182
reberryjr
R

Forum statistics

Threads
1,215,494
Messages
6,125,139
Members
449,207
Latest member
VictorSiwiide

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top