VBA, There isn't enough memory to process 50K csv files, timeout at 2k queries for a search, find, copy, past, loop

[InnosolInc]

HI,

I'm new to the forum and really new to VBA and could really use some expert assistance. This code provides a text box to "scrape many like files for keywords of your choice." It first performs a search for keywords, then once the keyword is found, takes the cell next to it and populates it on 1 spreadsheet. I added a few lines to this amazing code I found from this site, but I'm now receiving lack of memory errors. I tried to add a "save after a number of loops" loop to the code, but I've been unsuccessful. The code does everything I need it to do, but just hoping to find a way to allow it to run through all 50k CSV files. Thank you in advance!

Sub CopyRange()

Application.ScreenUpdating = False

Dim wkbDest As Workbook

Dim wkbSource As Workbook

Set wkbDest = ThisWorkbook

Dim LastRow As Long

Dim wOut As Worksheet

Dim wks As Worksheet

Dim rFound As Range

Dim strFirstAddress As String

Dim strSearch As String

Const strPath As String = "C:\Searchfolderhere\" 'change folder path to suit your needs

ChDir strPath

strExtension = Dir("*.csv*")

strSearch = InputBox("Please enter the Search Term.")

Set wOut = Worksheets.Add

wOut.Range("A1:D1") = Array("Workbook", "Worksheet", "Cell", "Text in Cell")

Do While strExtension <> ""

Set wkbSource = Workbooks.Open(strPath & strExtension)

With wkbSource

For Each wks In .Sheets

Set rFound = wks.Range("A:A").Find(strSearch, LookIn:=xlValues, lookat:=xlWhole)

If Not rFound Is Nothing Then

strFirstAddress = rFound.Address

Do

wOut.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0) = wkbSource.Name

wOut.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = wks.Name

wOut.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0) = rFound.Address

wOut.Cells(Rows.Count, "D").End(xlUp).Offset(1, 0) = rFound.Value

wOut.Cells(Rows.Count, "E").End(xlUp).Offset(1, 0) = rFound.next

Set rFound = wks.Range("A:A").FindNext(rFound)

Loop While rFound.Address <> strFirstAddress

sAddr = ""

End If

Next wks

End With

wkbSource.Close savechanges:=False

strExtension = Dir

Loop

Application.ScreenUpdating = True

End Sub

 

[Zot]

Try set to nothing to release reference counter at location below. Not sure if this works:

wkbSource.Close savechanges:=False
Set wkbSource = Nothing
Set rFound = Nothing
strExtension = Dir

You can put DoEvents in For or Do loop to prevent freeze but will slightly prolonged execution

 

[Marc L]

Hi,​

​

I could share another way - could be a bit faster - if you link some sample csv text files on a files host website like Dropbox​

with a sample of a word to be searched …​