vbstatsguy
New Member
I have a dataset that is about 70k rows and 100 columns (yes I know this should probably be in a dbase). This program loops through two of the columns and aggregates text. I create a dictionary object using the name column to create the key and then use the other column to add the value and every time the name comes up the value gets concatenated. For example column 88 in my example has the names Adam, John, Joe, Adam, Adam and column 92 has 125ab, 94b, 893b, 785t, 899r respectively. so this would create the following dictionary items:
dict.Adam = 125ab;785t;899r
dict.John = 94b
dict.Joe = 893b
Looping through the 70k rows and creating the dictionary portion of the code takes less than 1 second.
The second loop of the code creates about 120 directories and 5900 small files. This portion of the code takes over 2 minutes which seems really long.
This may just be a function of creating 5900 files in which case trying to speed this up is not possible. However, I thought I would see if there is a way to speed it up by asking here. Any help is appreciated.
Here is the code. Please note that the turnoffevents and turnonevents is calling routine to turn off screenupdating, events, etc...
dict.Adam = 125ab;785t;899r
dict.John = 94b
dict.Joe = 893b
Looping through the 70k rows and creating the dictionary portion of the code takes less than 1 second.
The second loop of the code creates about 120 directories and 5900 small files. This portion of the code takes over 2 minutes which seems really long.
This may just be a function of creating 5900 files in which case trying to speed this up is not possible. However, I thought I would see if there is a way to speed it up by asking here. Any help is appreciated.
Here is the code. Please note that the turnoffevents and turnonevents is calling routine to turn off screenupdating, events, etc...
Code:
Private dictHeatMap As New Scripting.Dictionary
Sub OutputHeatmaps()
Dim fso As Object
Dim myTable As ListObject
Dim myArray As Variant
Dim x As Long
Dim s As String
Dim arr As Variant
Dim i As Single
Dim sPath As String
Dim sFile As String
Dim Fileout As Object
StartTime = Timer
Call TurnOffEvents
'Set path for Table variable
Set myTable = Sheet2.ListObjects("tbl")
Set fso = CreateObject("Scripting.FileSystemObject")
'Create Array List from Table
myArray = myTable.DataBodyRange
i = 0 'Initialize counter to 0
'Loop through each item in Third Column of Table (displayed in Immediate Window [ctrl + g])
For x = LBound(myArray) To UBound(myArray)
If myArray(x, 88) <> "" Then
If dictHeatMap.Exists(myArray(x, 92)) Then
dictHeatMap(myArray(x, 92)) = dictHeatMap(myArray(x, 92)) & myArray(x, 88)
Else 'dictionary was already created so get the original string and add a new one
s = myArray(x, 92)
dictHeatMap.Add Key:=s, Item:=myArray(x, 88)
End If
End If
Next x
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation
StartTime = Timer
For Each Key In dictHeatMap.Keys
For x = LBound(myArray) To UBound(myArray)
If myArray(x, 92) = Key Then
'make spath the team directory
sPath = Range("HeatDir").Value2 & myArray(x, 89) & "\"
'Check to see if Team directory exists and if it doesn't, create it
If Dir(sPath, vbDirectory) = "" Then
MkDir sPath
End If
'make spath the player directory
sPath = sPath & myArray(x, 90) & "\"
'Check to see if player directory exists and if it doesn't, create it
If Dir(sPath, vbDirectory) = "" Then
MkDir sPath
End If
sFile = sPath & Key & ".txt"
Set Fileout = fso.CreateTextFile(sFile, True, True)
Fileout.Write dictHeatMap(Key)
Fileout.Close
End If
Next x
Next
Set dictHeatMap = Nothing
Set fso = Nothing
Set Fileout = Nothing
Call TurnOnEvents
MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", vbInformation
End Sub
Last edited by a moderator:
