Position in Target Array using For Each (Excel VBA) - arrays

I am trying to trap the changes that a user makes on a sheet.
I have my worksheet_change event setup but the issue is what if the Target.Range is larger than a single cell?
Basically, I need to evaluate each and every cell change to test for validity using a function. My issue is the Target.Range can be any size of course and the function to test for validity looks at the surrounding cells.
I was trying to trap the addresses of the changed cells using something like this:
i = 1
j = 1
For Each aCell In Target
DiffAddys(i, j) = aCell.Address
NewValues(i, j) = aCell.Value2
If i < Target.Rows.Count Then i = i + 1
If j < Target.Columns.Count Then j = j + 1
Next
That way I can trap the cells' address and then use aCell.Row or aCell.Column, etc. but this fails if the Target.Range is bigger than 2 columns since the i index grows faster than it should.
Is there anyway to find the position of "aCell" in the Target range as it is looped by the For Each? Or is it just best to trust that For Each always goes 1,1 1,2 1,3 2,1 2,2, etc.?
Any better methods? Maybe just copy the address of each aCell into a 1D array that is equal to rows*columns of the Target.Range that way the i/j indexes are irrelevant - and then process this 1D array instead of a 2D array?
Thanks,
BT

More info about what you need to do with the arrays and how you are doing it would help. But as for what you posted... Something like you suggested, using 1D arrays, should do the trick :
Private Sub Worksheet_Change(ByVal Target As Range)
Dim DiffAddys() As String, NewValues() As Variant
Application.EnableEvents = False
ReDim DiffAddys(Target.Cells.Count)
ReDim NewValues(Target.Cells.Count)
i = 1 'it is generaly not recommended to start array indexes on 1
For Each aCell In Target.Cells
DiffAddys(i) = aCell.Address
NewValues(i) = aCell.Value2
i = i + 1
Next aCell
Application.EnableEvents = True
End Sub
Or you could put the aCell.Address and aCell.Value2 into one 2D array.

Thanks to all for the suggestions. I just went ahead and took my own advice and went with the 1D array to store the addresses of the changed cells.
If Range("aq" & Target.Row).Value <> "p" And Target.Cells.Count <= 1 Then
Range("aq" & Target.Row).Value = 1
Application.EnableEvents = True
Exit Sub
End If
Application.ScreenUpdating = False
ReDim OldValues(1 To (Target.Rows.Count * Target.Columns.Count))
ReDim NewValues(1 To (Target.Rows.Count * Target.Columns.Count))
ReDim DiffAddys(1 To (Target.Rows.Count * Target.Columns.Count))
i = 1
For Each aCell In Target
DiffAddys(i) = aCell.Address
NewValues(i) = aCell.Value2
If i < (Target.Rows.Count * Target.Columns.Count) Then i = i + 1
Next
Application.Undo 'turn back time
For i = 1 To UBound(NewValues, 1) 'rows
OldValues(i) = Sheet5.Range(DiffAddys(i)).Value
Next i

Related

VBA: Write array to sheet in a block (one memory access)

I have a large array (45000 elements) that i need to write down in an excel sheet. However this is taking way to long when looping over the values (requesting a memory access for each value)
(I have already disabled features like screen updating)
I've found some ways to do it using the Variant type (french : https://www.lecfomasque.com/vba-rediger-des-macros-plus-rapides/) However i must be messing up at some point, see example code
Sub test()
Dim table(4) As Variant
Dim writeArray() As Variant
table(0) = 0
table(1) = 1
table(2) = 2
table(3) = 3
table(4) = 4
writeArray = table
'Supposed to write 0 to A1, 1 to A2,... but not working that way
Range("A1:A5").Value = writeArray
End Sub
This code writes only the first value (0) to the whole range, even if the variant writearray contains also the other values (1,2,3,4).
Any idea (without a memory request for each value) on how to solve this is welcome, Thank you ^-^
EDIT (SOLUTION)-----------------------
Paul's (transpose) and Mikku's (2D-array) solutions seem to work and both provide an tenfold reduction of execution time in my case. The transpose is slighly faster on average.
On this site I found this useful little piece...
Dim Destination As Range
Set Destination = Range("K1")
Destination.Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
You can transpose the array when writing to the worksheet:
Set Destination = Range("K1")
Destination.Resize(UBound(Arr, 2), UBound(Arr, 1)).Value = Application.Transpose(Arr)
Well a 2-D array can do that
Sub test()
Dim table(0 To 4, 1 To 1) As Variant
table(0, 1) = 0
table(1, 1) = 1
table(2, 1) = 2
table(3, 1) = 3
table(4, 1) = 4
Range("A1:A5") = table
End Sub
The underlying problem is that 1D array corresponds to a row in the sheet. So you can put
Range("A1:E1") = table
and it works fine.
If you want to put your array into a column, the easiest way is to use transpose as mentioned by #Paul:
writeArray = Application.WorksheetFunction.Transpose(table)
which gives you a 2D array with five rows and 1 column.
Sub test2()
Dim table(0 To 4) As Variant
Dim writeArray() As Variant
table(0) = 0
table(1) = 1
table(2) = 2
table(3) = 3
table(4) = 4
writeArray = Application.WorksheetFunction.Transpose(table)
Debug.Print ("ubound=" & UBound(writeArray, 1))
Debug.Print ("ubound=" & UBound(writeArray, 2))
Range("A1:A5") = writeArray
Range("A1:E1") = table
End Sub

Removing duplicates of a 2D array in VBA

I have found lots of methods to remove duplicates of a 1D array but could not find a 2D example.
In addition to that, I wonder if the fuction can "leave" an instance of the duplicate item instead of removing them all.
Is it possible to do it?
Example:
Sub Tests()
Dim Example()
Example(0,0) = "Apple"
Example(1,0) = "Apple"
Example(0,1) = "Pear"
Example(1,1) = "Orange"
End Sub
Remaining items would be: Apple, Pear and Orange
This is how I like to do it, using a separate array to hold the unique items. This prevents your loops from having to cycle through non unique items when trying to test them.
Sub Test()
Dim Example(1, 1) As String
Dim NoDups() As String
Dim I, II, III As Long
ReDim NoDups(UBound(Example, 1) * UBound(Example, 2))
For I = 0 To UBound(Example, 1)
For II = 0 To UBound(Example, 2)
For III = 0 To UBound(NoDups)
If NoDups(III) = Example(I, II) Then
Exit For
ElseIf NoDups(III) = "" Then
NoDups(III) = Example(I, II)
Exit For
End If
Next
Next
Next
End Sub
To work through a 2D array, do as you would with a 1D array, but with a 'width' loop inside of a 'height' loop.
ie:
for a = 1 to number_of_elements_in_first_dimension
for y = 1 to number_of_elements_in_second_dimension
initial_comparison_string = array(a,b)
for x = a to number_of_elements_in_first_dimension
for y = b + 1 to number_of_elements_in_second_dimension
if Initial_comparison_string = array(x,y) then array(x,y) = ""
next y
next x
next b
next a
This will run fairly slowly with a very large 2D array, but I think you'd have to do 2 nested loops like this to take each value and compare it against each value which appears later.

Populating an array with range VBA

I have been given the job of fixing a holiday spreadsheet at work, the problem with the document is that there are direct references, indirect references to other worksheets and some parts non referenced, so if you want to put people in a different order it completely messes the whole thing up. So, what I have been trying to do is to populate an array with the peoples names, sort the array, then cross reference that with the original and find a new order so that this new order can be implemented throughout the worksheets without messing things up.
The problem is that I can't seem to get the arrays to populate, I have looked at the other answers on here, but I'm sure I'm using redim properly and that tends to be the problem.
So Previous is the original listing, Current is the sorted list and Position is the number that relates the previous to the current.
Sub Sorting()
Dim Previous() As Variant
Dim Current() As Variant
Dim maxrow As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim Position() As Long
Dim rng As Range
Dim strTemp As String
k = 0
i = 3
maxrow = 3
Do While Worksheets(1).Cells(i, 1).Value <> "STAT.HOL'S (ST)"
maxrow = maxrow + 1
i = i + 1
Loop
maxrow = maxrow - 1
ReDim Previous(0 To maxrow)
ReDim Position(0 To maxrow)
ReDim Current(0 To maxrow)
Previous = Range("a4", Range("a" & maxrow))
Current = Previous
For i = 0 To maxrow
For j = 0 To maxrow
If Current(i) > Current(j) Then
strTemp = Current(i)
Current(i) = Current(j)
Current(j) = strTemp
End If
Next j
Next i
For i = 0 To maxrow
For j = 0 To maxrow
If Previous(i) = Current(j).Value Then
Position(k) = j
k = k + 1
End If
Next j
Next i
End Sub
Thanks for your help.
Amy
You do populate the arrays, but you are adressing them the wrong way.
When you assign a range to an array, the array is automatically redimensioned to a two-dimensional array, one for the rows and one for the columns.
Since your range is just one columm, the second dimension is always 1. So after you run the line Previous = Range("a4", Range("a" & maxrow)) you have an array that is dimensioned as:
Previous(1 to 10, 1 To 1)
Also, your For loops could be changed to something like this:
For i = LBound(Current, 1) To UBound(Current, 1)
Next i
Excel ranges are always treated as having 2 dimensions even when they are a single column.
Also you don't need to redim your variant arrays - just assign the range to a plain variant variable and it will create a variant containing a 2-dimensional array:
Dim Previous as variant
Previous = Range("a4:a" & maxrow)

Creating a function in VBA that has a dynamic array for an argument and its output is also a dynamic array

Here's what I'm trying to do:
Suppose that you have a dynamic array whose dimensions can be from 0x6 up to 10x6 (meaning we can have rows anywhere from 0 to 10, but columns are always 6). I have been desperately trying to create a function (and then bind it to a macro) that will use as argument this first array, and will create a second array as output, whose elements will be the returns of the first array. For example, if we have the simple case of 1x6, then the output array's elements are five and in each case are given by the formula (x_i+1 - x_i)/x_i, i=1, 2, ..., 6. Additionally, the function must be able to bypass any missing values from the input array and ignore the corresponding non-existent return values. The entire thing must be done in VBA script.
It's been two days since I have been searching frantically for some help, but the problem is that I have no idea whatsoever about programming in VBA (I usually use other languages like MATLAB or Mathematica) so this is extremely hard for me. Any solutions that I have found I wasn't able to put together and achieve my goal. Any help is greatly appreciated.
Because you provided no code, I cannot determine exactly what you want to do, but here is an example of passing an array and returning an array that you should be able to extrapolate.
Edit: Just for fun, updated this to work for up to 3 dimensional arrays.
Public Sub Test()
'Defines testArray as Variant 0 to 10
Dim testArray(0 To 1, 0 To 6) As Long
Dim returnArray() As Long
Dim i As Long
Debug.Print UBound(testArray, 2)
'Populates testArray with Longs
For i = 0 To UBound(testArray, 1)
For j = 0 To UBound(testArray, 2)
testArray(i, j) = (i + j) * 2
Next
Next
'Passes testArray and returns ParseArray
returnArray = addOne(testArray)
End Sub
Public Function addOne(arrValues() As Long) As Variant
Dim arrCopy() As Long
Dim dimensionNum As Long, ErrorCheck As Long
On Error Resume Next
For dimensionNum = 1 To 60000
ErrorCheck = LBound(arrValues, dimensionNum)
If Err.Number <> 0 Then
dimensionNum = dimensionNum - 1
Exit For
End If
Next
Dim i As Long, j As Long, k As Long
'Copies passed array to avoid updating passed array directly
arrCopy = arrValues
'Adds 1 to each element of the array.
If dimensionNum = 1 Then
For i = LBound(arrCopy) To UBound(arrCopy)
arrCopy(i) = arrCopy(i) + 1
Next
ElseIf dimensionNum = 2 Then
For i = LBound(arrCopy) To UBound(arrCopy)
For j = LBound(arrCopy, 2) To UBound(arrCopy, 2)
arrCopy(i, j) = arrCopy(i, j) + 1
Next
Next
ElseIf dimensionNum = 3 Then
For i = LBound(arrCopy) To UBound(arrCopy)
For j = LBound(arrCopy, 2) To UBound(arrCopy, 2)
For k = LBound(arrCopy, 3) To UBound(arrCopy, 3)
arrCopy(i, j, k) = arrCopy(i, j, k) + 1
Next
Next
Next
Else
MsgBox "Add function only works for three dimensions or fewer arrays"
End If
addOne = arrCopy
End Function

Copy a range of cells, defined on execution, to an array

I am trying to copy a range of cells from a range of rows from two workbooks. This information is used to do a comparison of the contents of both workbooks rows by ID.
The first solution I tried involved cell by cell "binary" comparison. This works for worksheets with few rows:
For i = 2 To LastSheetRow
Set FoundCell = Workbooks(WorkbookA).Sheets(SheetNameFromArray).Range("A:A").Find(What:=Workbooks(WorkbookB).Sheets(SheetNameFromArray).Cells(i, 1).Value)
If Not FoundCell Is Nothing Then
aCellValues(0) = 1
Workbooks(UserWorkbook).Sheets(SheetNameFromArray).Cells(i, LastSheetColumn + 1).Value = FoundCell.Row
For j = 2 To LastSheetColumn
Select Case Workbooks(WorkbookB).Sheets(SheetNameFromArray).Cells(i, j).Value
Case Is = Workbooks(WorkbookA).Sheets(SheetNameFromArray).Cells(FoundCell.Row, j).Value
aCellValues(j - 1) = 1
Case Else
aCellValues(j - 1) = 0
End Select
Next j
Else
End If
Next i
I would like to store the contents of one row of each of the two workbooks on one array to do the comparison, as I believe it's a faster solution.
After defining the range to do the comparison I encountered the following error when copying the cells into an array:
Subindex out of interval (Error 9)
This generates the error:
Dim aWorkbookBInfo() As Variant, aWorkbookAInfo() As Variant, rngWorkbookBToCompare As Range, rngWorkbookAToCompare As Range
Dim SumToCheck As Integer, FoundCell As Range, aCellValues() As Integer
ReDim aCellValues(LastSheetColumn - 1)
ReDim aWorkbookBInfo(LastSheetColumn - 1)
ReDim aWorkbookAInfo(LastSheetColumn - 1)
For i = 2 To LastSheetRow
Set FoundCell = Workbooks(WorkbookA).Sheets(SheetNameFromArray).Range("A:A").Find(What:=Workbooks(WorkbookB).Sheets(SheetNameFromArray).Cells(i, 1).Value)
If Not FoundCell Is Nothing Then
aCellValues(0) = 1
Workbooks(WorkbookB).Sheets(SheetNameFromArray).Cells(i, LastSheetColumn + 1).Value = FoundCell.Row
With Workbooks(WorkbookB).Sheets(SheetNameFromArray)
Set rngWorkbookBToCompare = Range(Cells(i, 2), Cells(i, LastSheetColumn))
End With
With Workbooks(WorkbookA).Sheets(SheetNameFromArray)
Set rngWorkbookAToCompare = Range(Cells(FoundCell.Row, 2), Cells(FoundCell.Row, LastSheetColumn))
End With
aWorkbookBInfo = rngWorkbookBToCompare
aWorkbookAInfo = rngWorkbookAToCompare
For j = 1 To LastSheetColumn - 1
If aWorkbookBInfo(j).Value = aWorkbookAInfo(j).Value Then
aCellValues(j) = 1
Else
aCellValues(j) = 0
End If
Next j
Else
End If
Next i
Complete Revision:
The range array assignment produces a two-dimensional array in these lines:
aWorkbookBInfo = rngWorkbookBToCompare
aWorkbookAInfo = rngWorkbookAToCompare
This happens regardless of how you defined and dimensioned them at the beginning of your code. Since they are a two-dimensional array, they must be addressed as aWorkbookBInfo(a, b) where a is a row and b is a column.
Unlike Ranges, where it is okay to reference the first cell in any range, you must fully address an array before attempting to reference the array item. So, while rngWorkbookBToCompare(j).Value works, aWorkbookBInfo(j).Value does not. Furthermore, Value is not necessarily a property of whatever object Excel puts in the array. If you want the first cell of column j, try adding the row and leaving off the reference to the Value property as in: aWorkbookBInfo(1, j).

Resources