3
\$\begingroup\$

This code load a 40MB txt into a dictionary. It runs in about 40 seconds (sometimes 20, no idea why). Is there a way to make it run under 4 seconds, or hopefully in 1 second?

Sub ScriptDic()

Dim FileNum As Integer
Dim DataLine As String
Dim tmp As Variant
Dim Dict As Object
Dim duplicatecount As Object
Dim key As String
Dim count As Long

Set Dict = CreateObject("Scripting.Dictionary")
Set duplicatecount = CreateObject("Scripting.Dictionary")

Sheets("Control").Cells(5, 3).Value2 = Now
Filename = "C:\Users\MyFolder\Documents\PerformanceTests\MyData.txt"
FileNum = FreeFile()


Open Filename For Input As #FileNum
While Not EOF(FileNum)
    Line Input #FileNum, DataLine ' read in data 1 line at a time
    tmp = Split(DataLine, Chr(9))
    key = tmp(7) & "-" & tmp(8)
    If Not Dict.exists(key) Then
        Dict.Add key, tmp
        duplicatecount.Add key, 1
    Else
        count = duplicatecount(key)
        duplicatecount.Remove (key)

        Dict.Add key & ">" & count, tmp
        duplicatecount.Add key, count + 1
    End If
Wend

Sheets("Control").Cells(6, 3).Value2 = Now
End Sub
\$\endgroup\$
  • \$\begingroup\$ How long does it take to simply read the 40GB file? Have you benchmarked it with only the file operations (no dictionaries)? \$\endgroup\$ – Comintern Sep 13 '16 at 22:17
  • \$\begingroup\$ Just read line by line takes 1 second. \$\endgroup\$ – BuckTurgidson Sep 13 '16 at 23:24
  • 3
    \$\begingroup\$ Are you sure your system can load a 40 GigaByte file in 1 second? A really fast SSD can theoretically read up to 2500MB/s, but reading 40GB in 1 second would be 16 times faster than that. Do you perhaps mean a 40MB file? \$\endgroup\$ – ThunderFrame Sep 14 '16 at 8:11
4
\$\begingroup\$

I assume you're working with a 40MB file instead of a 40GB file. The performance will vary greatly depending upon:

  • the length of each line in the file
  • the number of lines in the file
  • the number of uniquely keyed-lines in the file

I've worked with a contrived data-file that is 5.127MB in size and has 250,000 data rows like:

a   b   c   d   e   f   g   h   i   j
b   c   d   e   f   g   h   i   j   k
a   b   c   d   e   f   g   h   i   j

The file has nearly all duplicated records, so I'm pushing the limits on the unique key approach. A file with all unique values will perform differently.

Using your code against the 5MB file, it runs in 6.18s. If I only read the file, it reads in 0.11s. If I only read the file, split each line and build a key, it runs in 0.76s. So approximately 5.42s, or 88% of the duration is related to dictionary manipulation.

So, what can we do in VBA, to improve your code

Option Explicit You haven't included it in your code, so I assume it isn't declared.

Declare filename As String The filename variable isn't declared, although you may have declared it at global scope. Option Explicit shows e this right away.

Dim filename As String

Declare tmp as a String Array tmp is assigned with the Split function, which returns a String array, so declare tmp accordingly and you'll use a great deal less memory.

Dim tmp() As String

Early Binding You're using CreateObject("Scripting.Dictionary"), so your code will fail anyway, if Microsoft Scripting Runtime isn't available. But more importantly, by using late-binding, COM has to work harder to find the methods you're using. It's much better to early-bind by adding a reference to Microsoft Scripting Runtime.:

Dictionary variable names You've used ambiguous names: Dict and duplicatecount. You'd be better off with more meaningful names (I don't know what your data is, so I'm using less un-meaningful names) like:

Dim allRecords As Scripting.Dictionary
Dim uniqueKeyCounts As Scripting.Dictionary

Set allRecords = New Scripting.Dictionary
Set uniqueKeyCounts = New Scripting.Dictionary

Avoid using magic function/literal values You're referring to the Tab character Chr(9) which incurs time on every line. VBA has a built-in constant for Tab: vbTab, which makes it more efficient and easier to read.

tmp = Split(DataLine, vbTab)

Unique keys and Dictionary usage The code to build a unique key and populate the dictionaries is the most expensive, so let's be careful about checking the smallest dictionary more frequently than the large dictionary.

Also, there's no need to Remove and then Add back, when we can just increment the count of the existing entry.

If uniqueKeyCounts.Exists(key) Then
  'Retrieve the current count once
  Dim currentCount As Long
  currentCount = uniqueKeyCounts.Item(key)
  allRecords.Add key & ">" & currentCount, DataLine
  'Don't remove and re-add, just increment the counter
  uniqueKeyCounts(key) = currentCount + 1
Else
  uniqueKeyCounts.Add key, 1
  allRecords.Add key, tmp
End If

Close the file You've opened the file and read it all, but you've forgotten to close the file:

Close #FileNum

Timing events Using Now() offers very limited granularity. Timer gives you improved granularity but also a few problems when timed-code runs through midnight, but it avoids the need for win32 functions. If you want better timing see GetTickCount, or better still, QueryPerformanceCounter. I've used Timer for the sake of simplicity.

Dim start As Double
start = Timer
'...Do stuff...
Debug.Print Timer - start

So, when I put it altogether, the file is read in 4.85s, or about 22% faster.

Sub ScriptDic()

  'Declare fileName
  Dim filename As String

  Dim FileNum As Integer
  Dim DataLine As String
  'Declare tmp as a string array
  Dim tmp() As String
  'Declare as Scripting.Dictionary to get early-binding benefits
  Dim allRecords As Scripting.Dictionary
  Dim uniqueKeyCounts As Scripting.Dictionary
  Dim key As String
  Dim count As Long

  'USe early binding
  Set allRecords = New Scripting.Dictionary
  Set uniqueKeyCounts = New Scripting.Dictionary

  Sheets("Control").Cells(5, 3).Value2 = Now
  filename = "C:\Temp\test100k.txt"
  FileNum = FreeFile()

  Dim start As Double
  start = Timer
  Open filename For Input As #FileNum
  Do While Not EOF(FileNum)
      Line Input #FileNum, DataLine ' read in data 1 line at a time
      'USe the vbTab constant
      tmp = Split(DataLine, vbTab)
      key = tmp(7) & "-" & tmp(8)
      'Check the unique dictionary - it's almost always smaller
      If uniqueKeyCounts.Exists(key) Then
        'Retrieve the current count once
        Dim currentCount As Long
        currentCount = uniqueKeyCounts.Item(key)
        allRecords.Add key & ">" & currentCount, DataLine
        'Don't remove and re-add, just increment the counter
        uniqueKeyCounts(key) = currentCount + 1
      Else
        uniqueKeyCounts.Add key, 1
        allRecords.Add key, tmp
      End If
  Loop

  'Close the file
  Close #FileNum

  Debug.Print Timer - start
  Sheets("Control").Cells(6, 3).Value2 = Now
End Sub

But do you really want a Dictionary? Using the existing and optimized approach, you'll end up with a dictionary that is keyed by what seems to be an arbitrary index. You may have your reasons, but if you're not going to use the features of a dictionary, you might be better off with an array:

This code runs in just 1.56s.

Sub ScriptDic1()

  'Declare fileName
  Dim filename As String

  Dim FileNum As Integer
  Dim DataLine As String
  'Declare tmp as a string array
  Dim tmp() As String
  'Declare as Scripting.Dictionary to get early-binding benefits
  Dim uniqueKeyCounts As Scripting.Dictionary
  Dim key As String
  Dim count As Long

  Dim lineNumber As Long

  'Create an array that is larger than our needs, we'll resize it when we're done.
  ReDim allRecords(1, 500000) As Variant

  'USe early binding
  Set uniqueKeyCounts = New Scripting.Dictionary

  Sheets("Control").Cells(5, 3).Value2 = Now
  filename = "C:\Temp\test100k.txt"
  FileNum = FreeFile()

  Dim start As Double
  start = Timer
  Open filename For Input As #FileNum
  Do While Not EOF(FileNum)
      Line Input #FileNum, DataLine ' read in data 1 line at a time
      'USe the vbTab constant
      tmp = Split(DataLine, vbTab)
      key = tmp(7) & "-" & tmp(8)
      'Check the unique dictionary - it's going to be smaller
      If uniqueKeyCounts.Exists(key) Then
        'Retrieve the current count once
        Dim currentCount As Long
        currentCount = uniqueKeyCounts.Item(key)
        allRecords(0, lineNumber) = key & ">" & currentCount
        allRecords(1, lineNumber) = tmp
        'Don't remove and re-add, just increment the counter
        uniqueKeyCounts(key) = currentCount + 1
      Else
        uniqueKeyCounts.Add key, 1
        allRecords(0, lineNumber) = key
        allRecords(1, lineNumber) = tmp
      End If
      lineNumber = lineNumber + 1
  Loop

  ReDim Preserve allRecords(1, lineNumber - 1) As Variant
  'Close the file
  Close #FileNum

  Debug.Print Timer - start
  Sheets("Control").Cells(6, 3).Value2 = Now
End Sub
\$\endgroup\$
  • \$\begingroup\$ ok this is impressive. minor but interesting improvement aside, the fact that we skip 'remove' made my case run 3x faster. I do need to randomly access these record afterwards (in the case when the key has meaning = is unique) which is something like 2/3rds of the data. However your question in second example made me realize that when the key is not unique and has no meaning I can just use a count as index \$\endgroup\$ – BuckTurgidson Sep 14 '16 at 20:47
  • 1
    \$\begingroup\$ Here the final numbers: Old code was running at 15 sec today (no idea why). Final code (basically ScriptDic in the answer) runs in 5 sec. That compared with 3.7 seconds just to loop the file (0.6 sec), split and build key. So 1-1.5 secs to put the data into a dictionary. \$\endgroup\$ – BuckTurgidson Sep 14 '16 at 21:18
  • \$\begingroup\$ I'm wondering if I can make 5 seconds down to less then 1 second if I go down the C# path... \$\endgroup\$ – BuckTurgidson Sep 14 '16 at 21:29

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.