I am attempting to simplify my code when writing back data from an array into an Excel spreadsheet.
I have an array of 2 rows and 49 columns (the data is dates used for the horizontal part in a number of graphs). The date's adapt based on user-input and it is then written back into the Excel spreadsheet.
Currently I have written below code for loading the data into the array and writing it back into the spreadsheet (and it works as intended).
Dim LocalArray() As Variant
LocalArray = Sheets("Data").Range("L4003:BH4004").Value2
.Range("M280").Resize(UBound(LocalArray, 1), UBound(LocalArray, 2)) = LocalArray
.Range("M336").Resize(UBound(LocalArray, 1), UBound(LocalArray, 2)) = LocalArray
.Range("M394").Resize(UBound(LocalArray, 1), UBound(LocalArray, 2)) = LocalArray
Above is only part of the code though as I need to include the array in 15 different places (graphs). Hence I repeat the same line of code a lot of times which seems very ineffecient.
I have tried using below simple line of code to write the array data back into the spreadsheet:
.Range("M280:BI281,M336:BI337,M394:BI395").Value2 = LocalArray
However, writing back the array data using above code makes every second range appear wrong with cells including N/A (ref. below picture).
How do I write this code the simplest way possible (and requiring as little processing power from the user's PC as possible)?
Thank you very much!
It is much easier to examine and remember the dimensions of the source range.
Say we have data in a rectangular set of cells from B2 through D3:
That we wish to copy elsewhere several times. The first time will be a block starting at E6:
Sub dural()
Dim LocalArray() As Variant
Dim rng As Range, rw As Long, cl As Long
Set rng = Sheets("Sheet1").Range("B2:D4")
rw = rng.Rows.Count
cl = rng.Columns.Count
LocalArray = rng.Value2
Range("E6").Resize(rw, cl) = LocalArray
End Sub
Running this yields:
So all we need to remember is rw and cl.
EDIT#1:
For an easy way to loop the deposits:
Sub dural()
Dim LocalArray() As Variant
Dim rng As Range, rw As Long, cl As Long
Dim a
Set rng = Sheets("Sheet1").Range("B2:D4")
rw = rng.Rows.Count
cl = rng.Columns.Count
LocalArray = rng.Value2
Range("E6").Resize(rw, cl) = LocalArray
' Now try looping
For Each a In Array("a12", "b16", "c23")
Range(a).Resize(rw, cl) = LocalArray
Next a
End Sub
Related
I have a simple macro that includes a dynamic array which fills up upon conditions are met. The data populates the macro as it is supposed to be functioning until it paste the data onto the spreadsheet. Now, all data is pasted correctly except for date values. Date values are pasted erroneously from European format to American format onto the spreadsheet (i.e. dd-mm-yyyy to mm-dd-yyyy). So for instance a 1st march 2019 becomes a 3rd January 2019 on the spreadsheet. Note that either I format beforehand the destination files or not, the problem still occurs.
The array has 14 columns and only column 12-13 are date values.
Edit Summary
Shredded the code from irrelevant information; added images of results.
Following is the code
Sub Verification()
Dim NewWorkbook As String, NewWorksheet As String
Dim wb As Workbook, sh As Worksheet
Dim LoopCounter As Long
Dim NewEntryCounter As Long
Dim Cols As Long, Rows As Long
Dim r As Range
Dim arr As Variant, NewEntry() As Variant
Dim myRange As Integer
NewWorkbook = LCase(InputBox("What is the name of the new report?"))
NewWorksheet = LCase(InputBox("What is the name of the sheet?"))
Set wb = ThisWorkbook
Set sh = wb.Sheets("Renouvellement")
Cols = Workbooks(NewWorkbook).Sheets(NewWorksheet).Range(Workbooks(NewWorkbook).Sheets(NewWorksheet).Cells(1, 1), Workbooks(NewWorkbook).Sheets(NewWorksheet).Cells(1, 1).End(xlToRight)).Count
Rows = sh.Range(sh.Cells(1, 1), sh.Cells(1, 1).End(xlDown)).Count
For Each r In Workbooks(NewWorkbook).Sheets(NewWorksheet).Range("A2", Workbooks(NewWorkbook).Sheets(NewWorksheet).Range("A1").End(xlDown))
If (r.Offset(0, 21).Text = "Red" Or r.Offset(0, 21).Text = "Blue") And r.Offset(0, 17).Value >= 24 Then
arr = Application.VLookup(r.Value, sh.Range("A:A"), 1, 0)
If IsError(arr) Then
NewEntryCounter = NewEntryCounter + 1
ReDim Preserve NewEntry(1 To Cols, 1 To NewEntryCounter)
For LoopCounter = 1 To Cols
NewEntry(LoopCounter, NewEntryCounter) = r.Offset(0, LoopCounter - 1)
Next LoopCounter
Else
End Sub
Sample results from Local window
Sample results when transferring date values onto spreadsheet
As you can see the first value inserted is changed when transferring data from vba to spreadsheet. The second value is correctly transferred. The third is not, and so on.
Again, it's a bit difficult for me to understand exactly what you're doing, but it seems that a filter might be simpler, so far as the copying of relevant data is concerned.
In your code, you are making multiple calls to the worksheet, and multiple Redim Preserve operations on the VBA array. Those operations can be costly.
Perhaps that part of the code could be simplified (and sped up) with something like (obviously, you may need to change the worksheet and range variables):
Set ws = Worksheets("sheet1")
Set r = ws.Range("a1").CurrentRegion
With r
.AutoFilter field:=22, Criteria1:="red", Operator:=xlOr, Criteria2:="blue"
.AutoFilter field:=18, Criteria1:=">=24"
End With
r.SpecialCells(xlCellTypeVisible).Copy
'Paste somewhere
ws.ShowAllData
I have a massive Excel template that's having performance issues. I'd like to optimize the VBA code I'm using to modify cells to be more of an "all at once" approach. I have several basic functions using loops to modify values. Here's an example:
Dim aCell as Range
For Each aCell In Range("A1:A9999").Cells
'appends prefix to value of each cell
aCell.Value = "CC_" & aCell.Value
Next aCell
While this works, the drawback of this is that it causes several recalculations and updates that slows down the template. I'm familiar with turning calculations/screen updating on and off, but for reasons I won't go into, that's not an option.
This code below does NOT work, but it's the approach I'm looking for. Is there a way to make such a change using an array or some other tool I'm not thinking of that would minimize the templates calculation updates?
Range("A1:A9999").Value = "CC_" & Range("A1:A9999").Value
Thank you!
Reading/writing to/from the worksheet takes a lot of time. Do the modifications within a VBA array, then write it back.
Dim myRange As Range, myArr As Variant
Set myRange = Range("A1:A9999")
myArr = myRange
For i = 1 To UBound(myArr, 1)
myArr(i, 1) = "CC_" & myArr(i, 1)
Next i
myRange = myArr
You could temporarily create a column full of functions, then paste those values over the column A values:
Range("XFD1:xfd9999").Formula = "=""CC_""&A1"
Calculate
Range("A1:a9999").Value = Range("XFD1:XFD8").Value
Range("XFD1:XFD9999").ClearContents
I'm operating on the assumption here that you are not using column XFD for anything else. If you are, you could use a different column for this purpose.
FWIW, you can do it without a loop using Evaluate like this:
Sub addText()
With Range("A1:A9999")
.Value2 = .Worksheet.Evaluate("INDEX(""CC_""&" & .Address & ",)")
End With
End Sub
I was revisiting this (trying to still make it faster) and now that I have a little better understanding, I would recommend an approach shown below. The accepted answer is hard-coded for one column, which was my example asked, but the below approach is more dynamic.
Sub sampleArraySheetEdit()
Dim aRange As Range: Set aRange = Range("A1:B9999") ' or whatever your range is...
Dim vRng() As Variant: vRng = aRange
Dim r As Long, c As Long
For r = LBound(vRng, 1) To UBound(vRng, 1) 'this ensures all cells always accounted for
For c = LBound(vRng, 2) To UBound(vRng, 2)
'perform you operation here....
vRng(r, c) = "CC_" & vRng(r, c)
Next c
Next r
aRange = vRng
End Sub
I have become stuck trying to solve a piece of code I thought would be very simple.
I have defined a range (2 rows, 150 columns) and transferred it to an array. I then want to use the defined array in multiple ranges (same size of 2 rows and 150 columns). I have written the following code:
Dim LocalArray As Variant
LocalArray = .Range("FD6781:KW6782").Value2
.Range("FD6839:KW6840,FD6955:KW6956,FD7013:KW7014,FD7071:KW7072").Value2 = LocalArray
The issue is that every second range defined in .range("FD6839:KW6840,FD6955:KW6956...") shows up as N/A. Hence range FD6839:KW6840 is correct while range FD6955:KW6956 is wrong.
What have I done wrong in the above code?
Thank you!
You could loop. Otherwise, it does seem to be related to the number of columns causing the issue. Seems odd.
Option Explicit
Public Sub test()
Dim localArray(), rng As Range, ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet3")
localArray = ws.Range("FD6781:KW6782").Value2
For Each rng In ws.Range("FD6839, FD6955, FD7013, FD7071")
rng.Resize(UBound(localArray, 1), UBound(localArray, 2)) = localArray
Next
End Sub
So I have an array with a lot of data, I used to write the data to excel sheet via for cycle, but it took too long, so I looked into faster alternatives.
Now I try to display the information with setting a value of range of cells directly to array:
Sub displayRandomMatrix(clientsColl As Collection, resultWorkbook As Workbook)
Dim NamesRange As Range
With resultWorkbook.Worksheets("matrix_random")
...
Set NamesRange = _
.Range(.Cells(2, 1), .Cells(clientsColl.Count + 1, 1))
Dim NamesArray() As String
ReDim NamesArray(1 To clientsColl.Count)
Dim clientRow As Long
Dim simulation As Long
clientRow = 1
simulation = 1
Dim clientCopy As client
For Each clientCopy In clientsColl
For simulation = 1 To clientCopy.getRandomNumbers.Count
...
Next
NamesArray(clientRow) = clientCopy.getClientName
clientRow = clientRow + 1
Next
...
NamesRange.value = NamesArray
...
End With
'debugging
Debug.Print "**************start"
For clientRow = 1 To clientsColl.Count
Debug.Print NamesArray(clientRow)
Next
Debug.Print "**************end"
End Sub
However when I then open a resultWorkbook I see that the same client's name is written in all the needed cells of the 1st column. At the same the debug section of the code produces correct output - there are correct multiple clients names in that array.
So something gets broken when I assign that array to a range: NamesRange.value = NamesArray.
At the same time I do similar thing with other arrays and it works, but this while comes out with the bug.
What might be the reason?
NOTE: clientsColl is a good, correct collection of Clients. There is nothing wrong with it, neither is with resultWorkbook.
NamesArray is a horizontal array, which you are trying to assign to a vertical range. Try using Application.Transpose
NamesRange.value = Application.Transpose(NamesArray)
Transpose is a quick fix but has its limitations. So if that does not work you will need to force a vertical array by declaring a 2nd dimension in your array:
ReDim NamesArray(1 To clientsColl.Count, 1 to 1)
Then when you fill it make sure to include the second dimension:
NamesArray(clientRow,1) = clientCopy.getClientName
Then you can assign it as you have:
NamesRange.value = NamesArray
I am trying to find the fastest way to perform a task in VBA. Currently I have it written as a nested for loop which can be extremely slow. I am looping over a list of unique numbers and matching them to numbers in a different list. If I get a match I store the information in a multidimensional array since there can be multiple matches and I want to keep track of all of them. Unfortunetly, this means when using a for loop if there are just 1000 unique numbers and 5000 numbers to look for matches my loop can end up iterating 1000*5000 = 5000000 times. As you see this can create a problem quickly. I am asking if there is any better way to approach this problem while staying in VBA. I already did all the tricks like set screenUpdating to false and calculation to manaul.
Here is my code:
For x = 0 To UBound(arrUniqueNumbers)
Dim arrInfo() As Variant
ReDim Preserve arrInfo(0)
If UBound(arrInfo) = 0 Then
arrInfo(0) = CStr(arrUniqueNumbers(x))
End If
For y = 2 To Length
UniqueString = CStr(arrUniquePhoneNumbers(x))
CLEARString = CStr(Sheets(2).Range("E" & y).Value)
If UniqueString = CLEARString Then 'match!
NormalizedDate = Format(CStr(Sheets(2).Range("G" & y).Value), "yyyymmdd")
z = z + 1
ReDim Preserve arrInfo(z)
arrInfo(z) = NormalizedDate & " " & LTrim(CStr(Sheets(2).Range("D" & y).Value))
arrInfo(z) = LTrim(arrInfo(z))
End If
Next
arrUniqueNumbers(x) = arrInfo()
ReDim arrInfo(0) 'erase everything in arrOwners
z = 0
Next
The loop is quite inefficient, so there are quite a few avoidable bottlenecks (mostly in the order of simplest to change to most complex to change)
Take the UniqueString step out of the innermost loop: This step doesn't change with changing y, so no point in repeating it.
Take the Redim Preserve out of the innermost loop: You are reallocating memory in the innermost loop which is extremely inefficient. Allocate 'sufficient' amount of memory outside the loop.
Do not keep using Sheets().Range() to access cell contents: Every time you access something on the spreadsheet, it is a HUGE drag and has a lot of overhead associated with the access. Consider one-step fetch operations from the spreadsheet, and one-step push operations back to the spreadsheet for your results. See sample code below.
Sample code for Efficient Fetch and Push-back operations for the spreadsheet:
Dim VarInput() As Variant
Dim Rng As Range
' Set Rng = whatever range you are looking at, say A1:A1000
VarInput = Rng
' This makes VarInput a 1 x 1000 array where VarInput(1,1) refers to the value in cell A1, etc.
' This is a ONE STEP fetch operation
' Your code goes here, loops and all
Dim OutputVar() as Variant
Redim OutputVar(1 to 1000, 1 to 1)
' Fill values in OutputVar(1,1), (1,2) etc. the way you would like in your output range
Dim OutputRng as Range
Set OutputRng = ActiveSheet.Range("B1:B1000")
' where you want your results
OutputRng = OutputVar
' ONE STEP push operation - pushes all the contents of the variant array onto the spreadsheet
There are quite a few other steps which can further dramatically speed up your code, but these should produce visible impact with not too much effort.
dim dict as Object
set dict = CreateObject("Scripting.Dictionary")
dim x as Long
'Fill with ids
'Are arrUniqueNumbers and arrUniquePhoneNumbers the same?
For x = 0 To UBound(arrUniqueNumbers)
dict.add CStr(arrUniquePhoneNumbers(x)), New Collection
next
'Load Range contents in 2-Dimensional Array
dim idArray as Variant
idArray = Sheets(2).Cells(2,"E").resize(Length-2+1).Value
dim timeArray as Variant
timeArray = Sheets(2).Cells(2,"G").resize(Length-2+1).Value
dim somethingArray as Variant
somethingArray = Sheets(2).Cells(2,"D").resize(Length-2+1).Value
dim y as Long
'Add Values to Dictionary
For y = 2 To Length
Dim CLEARString As String
CLEARString = CStr(timeArray(y,1))
If dict.exists(CLEARString) then
dict(CLEARString).Add LTrim( Format(timeArray(y,1)), "yyyymmdd")) _
& " " & LTrim(CStr(somethingArray(y,1)))
end if
next
Access like this
dim currentId as Variant
for each currentId in dict.Keys
dim currentValue as variant
for each currentValue in dict(currentId)
debug.Print currentId, currentValue
next
next