Excel VBA: Writing an array to cells is very slow - performance

I am working with VBA in Excel to retrieve some information from the Reuters 3000 Database. The data I retrieve comes as a bidimensional array consisting of one column holding dates and other column holding numeric values.
After I retrieve the information, a process that takes no more than 2 seconds, I want to write this data to a worksheet. In the worksheet I have a column with dates and several other columns with numeric values, each column containing values of a same category. I iterate over the rows of the array to get the date and numeric value and I keep those in a variable, then I search for the date on the date column of the worksheet and after I've found the date I write the value. Here is my code:
Private Sub writeRetrievedData(retrievedData As Variant, dateColumnRange As String, columnOffset As Integer)
Dim element As Long: Dim startElement As Long: Dim endElement As Long
Dim instrumentDate As Variant: Dim instrumentValue As Variant
Dim c As Variant: Dim dateCellAddress As Variant
Application.ScreenUpdating = False
Sheets("Data").Activate
startElement = LBound(retrievedData, 1): endElement = UBound(retrievedData, 1)
Application.DisplayStatusBar = True
Application.StatusBar = "Busy writing data to worksheet"
For element = startElement To endElement
instrumentDate = retrievedData(element, 1): instrumentValue = retrievedData(element, 2)
Range(dateColumnRange).Select
Set c = Selection.Find(What:=instrumentDate, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not c Is Nothing Then
c.offset(0, columnOffset).Value = instrumentValue
End If
Next element
Application.DisplayStatusBar = False
End Sub
My problem is that this process is very slow, even if I have only 5 rows in the array it takes about 15 seconds to complete the task. As I want to repeat this process several times (once per each set of data I retrieve from the database), I would like to decrease the execution time as much as possible.
As you can see, I am disabling the update of the screen, which is one of the most recurrent actions to improve performance. Does anybody have a suggestion on how I can further decrease the execution time?
PS. I know the data retrieval process does not take much because I already tested that part (displaying values on a MsgBox as soon as the data has been retrieved)
Thanks in advanced.

This is what I did to improve the performance:
Avoid selecting the cell when the value is going to be written. This was a suggestion of Tim Williams.
I set the property Application.Calculation to xlCalculationManual
Instead of using the Find() function to search for the date, I loaded all the dates from the worksheet into an array and iterate over this array to get the row number. This turns out to be faster than the Find() function.
Private Function loadDateArray() As Variant
Dim Date_Arr() As Variant
Sheets("Data").Activate
Date_Arr = Range(Cells(3, 106), Cells(3, 106).End(xlDown))
loadDateArray = Date_Arr
End Function
Private Function getDateRow(dateArray As Variant, dateToLook As Variant)
Dim i As Double: Dim dateRow As Double
For i = LBound(dateArray, 1) To UBound(dateArray, 1)
If dateArray(i, 1) = dateToLook Then
dateRow = i
Exit For
End If
Next i
getDateRow = dateRow
End Function
Thank you all for your help!

By not selecting the sheet, you can add a bit more speed. Instead of
Sheets("Data").Activate
Date_Arr = Range(Cells(3, 106), Cells(3, 106).End(xlDown))
loadDateArray = Date_Arr
Try
With Sheets("Data")
Date_Arr = .Range(Cells(3, 106), Cells(3, 106).End(xlDown))
End With

Related

Iterate over all selected rows of SSDBGrid to fill an array

I need to iterate over all of the selected rows in an SSDBGrid. Then, I need to get the value in the current row and populate the relevant place in the array with this value.
I've been attempting to do this with the code below:
Dim i As Integer
i = 0
Dim nomCode(Grd_Nominal.SelBookmarks.Count) As String ' This is my array.
Do While Grd_Nominal.SelBookmarks <> 0
nomCode(i) = Grd_Nominal.SelBookmarks(0)
If Grd_Nominal.SelBookmarks.Count > 0 Then
Grd_Nominal.SelBoomarks(0).Remove
End If
i = i + 1
Loop
However, nomCode(i) is always being filled as nomCode(i) = "??"
Why is it inserting "??", and how can I fix this to insert the value of the current row?
You need to first of all re-think how you're declaring your array.
Dim nomCode() As String
ReDim nomCode(Grd_Nominal.SelBookmarks.Count - 1) As String
This is because when declaring an array you need to pass in a constant as the length. ReDim doesn't, so this will go partly towards solving the issue.
Dim x As Integer
Dim bk As Variant
For x = 0 to Grd_Nominal.Rows.Count - 1
bm = Grd_Nominal.SelBookmarks(x)
nomCode(x) = Grd_Nominal.Columns("Your_Column").CellValue(bm)
Next
This should sort the rest of the issue, I think.

Creating a Stacked Column graph

So I've seen a couple posts on this topic, but can't seem to find a way to get it to work. My goal is to create a Stacked Column Graph using VBA with the following characteristics:
Each column is based on data from a row (e.g. E6:P6, E7:P7, etc.).
Each "stack section" is each column in that row (located at E4:P4)
X Axes Labels are located in column A (e.g. A6, A7, etc.)
Y Axes Labels dynamic based on data (non specific).
Chart Title (which is the easy part - I got this).
Granted I also need the legend which shows the color key used by item 2.
This graph is one of three needed per report across 30+ reports that I generated via VBA from a raw data file. The last step to the reports is to make these graphs.
I am able to get stacked graph created, but the biggest problem is that as the data ranges above show, there are gaps in the data. This causes split sections in the graph as well as additional labels that I don't want. Essentially I don't know how to format the graph, and reading the Object Window that pops up from typing "ActiveChart." has only gotten me this far. If I know various formatting commands (alas I'm new to VBA with Excel), I can replicate it across all the charts that I need.
Dim data As Range
Set data = Range("A4:P12")
With Charts.Add
.ChartType = xlColumnStacked
.SetSourceData Source:=data, PlotBy:=xlColumns
.HasTitle = True
.ChartTitle.Text = "Weekly Report"
.Location Where:=xlLocationAsObject, Name:="Sheet1"
End With
Example of what I can make:
Output Graph
Side note about the blank data: The leftmost blank spot where a bar would be is the empty column D. Also I need to be able to edit the axes labels.
How about something like this:
Public Sub MakeGraph()
Dim ws As Excel.Worksheet
Dim data As Excel.Range
Dim x_axis_labels As Excel.Range
Dim series_names As Excel.Range
Dim sh As Excel.Shape
Dim ch As Excel.Chart
Dim I As Long
Set ws = Sheet1
Set data = ws.Range("E4:P12") ' Assumes the data are in E4:P12
Set x_axis_labels = ws.Range("A4:A12") ' Assumes the labels are in A4:A12
Set series_names = ws.Range("E2:P2") ' Assumes the labels are in E2:P2
Set sh = ws.Shapes.AddChart
Set ch = sh.Chart
With ch
.ChartType = xlColumnStacked
.SetSourceData Source:=data, PlotBy:=xlColumns
.HasTitle = True
.ChartTitle.Text = "Weekly Report"
.Axes(xlCategory, xlPrimary).CategoryNames = x_axis_labels
' Add series names
For I = 1 To .SeriesCollection.Count
.SeriesCollection(I).Name = series_names.Cells(1, I)
Next I
End With
Set ch = Nothing
Set sh = Nothing
Set series_names = Nothing
Set x_axis_labels = Nothing
Set data = Nothing
Set ws = Nothing
End Sub
Hope that helps
I take it your missing data would be a column in the range E6:P14? (I'm using E6:P14 because that's what you said first. Your code and #xidgel's later said E4:P12.)
Try this:
Sub MakeChart()
Dim rCats As Range
Dim rNames As Range
Dim rData As Range
Dim iCol As Long
Set rCats = ActiveSheet.Range("A6:A14")
Set rNames = ActiveSheet.Range("E4:P4")
Set rData = ActiveSheet.Range("E6:P14")
With ActiveSheet.Shapes.AddChart(xlColumnStacked).Chart
Do Until .SeriesCollection.Count = 0
.SeriesCollection(1).Delete
Loop
For iCol = 1 To rData.Columns.Count
If WorksheetFunction.Count(rData.Columns(iCol)) > 0 Then
' it's not blank
With .SeriesCollection.NewSeries
.Values = rData.Columns(iCol)
.XValues = rCats
.Name = "=" & rNames.Cells(1, iCol).Address(, , , True)
End With
End If
Next
End With
End Sub

Optimize performance of Removing Hidden Rows in VBA

I am using the following code to remove hidden/filtered lines after applying autofilters to a big sheet in VBA (big means roughly 30,000 rows):
Sub RemoveHiddenRows()
Dim oRow As Range, rng As Range
Dim myRows As Range
With Sheets("Sheet3")
Set myRows = Intersect(.Range("A:A").EntireRow, .UsedRange)
If myRows Is Nothing Then Exit Sub
End With
For Each oRow In myRows.Columns(1).Cells
If oRow.EntireRow.Hidden Then
If rng Is Nothing Then
Set rng = oRow
Else
Set rng = Union(rng, oRow)
End If
End If
Next
If Not rng Is Nothing Then rng.EntireRow.Delete
End Sub
The code comes from here: Delete Hidden/Invisible Rows after Autofilter Excel VBA
Moreover I read this thread: Speeding Up Code that Removes Hidden Rows on a Sheet
The situation: I have applied 5 different filters to a table consisting of 12 columns, therefore a lot of rows are filtered out (hidden) after the process. When I try to delete those, the code above takes a very long time. In my case I don't know if Excel was still working, so I had to force an exit. That leads to the following question:
Is there any other way than looping through all the hidden rows and deleting them?
An idea which came to my mind was to copy only the remaining unfiltered (that is non-hidden) content to a new sheet and afterwards delete the old sheet, which contains the full information. If so, how can that be done?
I don't think you need to involve another worksheet. Simply copy the rows below the existing Range.CurrentRegion property and then remove the filter and delete the original data.
Sub RemoveHiddenRows()
With Sheets("Sheet10")
With .Cells(1, 1).CurrentRegion
With .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
If CBool(Application.Subtotal(103, .Columns(1))) Then
.Cells.Copy Destination:=.Cells(.Rows.Count + 1, 1)
End If
.AutoFilter
.Cells(1, 1).Resize(.Rows.Count, 1).EntireRow.Delete
End With
End With
End With
End Sub
You may also receive some good, focused help on this subject by posting on Code Review (Excel).
You can improve performance significantly with a function like this:
Option Explicit
Public Sub deleteHiddenRows(ByRef ws As Worksheet)
Dim rngData As Range, rngVisible As Range, rngHidden As Range
With ws
Set rngData = .UsedRange
With rngData
Set rngVisible = .SpecialCells(xlCellTypeVisible)
Set rngHidden = .Columns(1)
End With
End With
If Not (rngVisible Is Nothing) Then
ws.AutoFilterMode = False
' invert hidden / visible
rngHidden.Rows.Hidden = False
rngVisible.Rows.Hidden = True
' delete hidden and show visible
rngData.SpecialCells(xlCellTypeVisible).Delete
rngVisible.Rows.Hidden = False
End If
End Sub
I tested it on a file with 2 filters applied to it
The function was adapted from the code in this suggestion

Speeding up adding validation lists to a spread range of cells using vba

I am working with a fairly small worksheet that has been developed by someone else. In this worksheet I have approx. 500 rows and some 100 columns (these values change dynamically).
The document adds validation lists to some cells based on a named range in another worksheet in the same workbook. This currently works, but very slowly.
The cells I would like to target are cells that on the same row, in column A, have a certain value. The cells should also have a specific name in its "header".
Currently, I am using a find statement to find all correct columns, and then for each of those columns I check the value in column A for the correct one, and if it is, I add the range.
Now to the question; How can I speed this up? When the sheet is at its largest it takes over a minute to complete the code, and since that happens when you open the sheet, people using the sheet are complaining. :)
Application.ScreenUpdating = False
Application.EnableEvents = False
Sheets(A).Activate
Sheets(A).Unprotect Password:=Str_SheetPassword
'Get each data ranges
Set Rg_TitleRange = ...
Set Rg_dataRange = ...
'Loop on each column that contains the keyword name
Set Rg_ActionFound = Rg_TitleRange.Find(Str_ColName, LookIn:=xlFormulas, _
lookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=True)
If Not Rg_ActionFound Is Nothing Then
'Loop on each action column
Do
'For each data row, update the cells with validation list
For Int_RowIndex = 0 To Rg_dataRange.Rows.Count - 1
'Change cells wich are at the intersection of test definition row and action name column.
If Rg_dataRange(Int_RowIndex, 1) = Str_RowName Then
Set Val_ActionValidationList = Rg_dataRange(Int_RowIndex, Rg_ActionFound.Column).Validation
Val_ActionValidationList.Delete
Rg_dataRange(Int_RowIndex, Rg_ActionFound.Column).Validation.Add _
Type:=xlValidateList, Formula1:=("=" + Str_ValidationList)
End If
Next
'Loop end actions
Int_PreviousActionFoundColumn = Rg_ActionFound.Column
Set Rg_ActionFound = Rg_TitleRange.Find(CommonDataAndFunctionMod.Str_ActionNameRowLabel, Rg_ActionFound, LookIn:=xlValues, lookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=True)
Loop While Rg_ActionFound.Column > Int_PreviousActionFoundColumn
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
I have tested to just comment out the row where the validation is added, so I'm fairly sure that row is the time consumer (mostly). I would take any suggestions.
Thank you in advance!
After some tries I ended up redoing the code so that this routine is run on certain other events instead, hence removing the loading time on start up. The validations are updated only when needed now.
Thank you all for your suggestions!
As you used Loop inside a loop will always slows down the code. think of different algorithm try to use Exit Loop and Exit Do When to cut down the looping time.

Lotusscript : How to sort the field values (an array of words) by their frequency

I would like to sort the field values (strings) by their frequency in lotusscript.
Has anyone an idea to solve this?
Thanks a lot.
Personally I would avoid LotusScript if you can help it. You are going to run into limitations that cannot be worked around.
Regardless of which route you do take, from a performance point of view it is better to have the View indexes do the work.
So you would create a view. The first column would be as follows.
Column Value: The field you want to check.
Sort: Ascending
Type: Categorized
After this you can access the data using the NotesViewNavigator. The related method call is getNextCategory. This will give you a view entry object which you can call ChildCount on to get totals.
For example (Disclaimer: Code written from memory, not guaranteed to run):
Dim sess As New NotesSession
Dim db As NotesDatabase
Dim vw As NotesView
Dim nav as NotesViewNavigator
Dim entryA As NotesViewEntry
Dim entryB As NotesViewEntry
Set db = sess.CurrentDatabase
Set vw = db.GetView("testView")
vw.AutoUpdate = False
Set nav = vw.CreateViewNav
Set entryA = nav.GetFirst
while entryA not Nothing
Set entryB = nav.GetNextCategory(entryA)
if entryB not nothing then
' Do your processing.
' entryB.childCount will give total.
end if
set EntryA = EntryB
Wend
view.AutoUpdate = True
This way the heavy lifting (string sorting, counting) is handled by the View index. So you only need to process the final results.
To answer the op's (old) question directly, the way to do this in LotusScript is both simple and easy:
dim para as string
dim words as variant
dim fq list as long
'get the text to freq-count
para = doc.text '(or $ from somewhere)
'tidy up para by removing/replacing characters you don't want
para = replace(para, split(". , : ; - [ ] ()"), "")
words = split(para) 'or split(words, "delim") - default is space
forall w in words
if iselement(words(w)) then
fq(w) = fq(w) + 1
Else
fq(w) = 1
End forall
'you now have a count of each individual word in the FQ list
'to get the words out and the word frequencies (not sorted):
forall x in fq
print listtag(x) = x
End forall
Thats it. No issue with LotusScript - quick and easy (and lists can be massive). To get a sorted list, you would have to move to an array and do a sort on it or move to a field and let #sort do the job somehow.

Resources