I have a function that loads certain data from a dynamic table into an array. The function works fine, when I check the local window I get the correct data. Also when I call the data from a sub, everything seems to work fine till I write the array to a new sheet, then I only get the first record repeatedly.
This is my code:
Function LoadData() As String()
Dim rng2 As Range, intJaNein As Integer, rngZelle As Range, X As Integer, cntAnzahl As Integer
Dim strAusgabe() As String 'R?ckgabe Array
intJaNein = 1
X = 0
Set rng2 = Range("tblMaschinen[DisplayList]")
cntAnzahl = WorksheetFunction.CountIfs(rng, m_intListIndex, rng2, intJaNein)
ReDim strAusgabe(cntAnzahl)
For Each rngZelle In rng2.Cells
If rngZelle.Offset(, -2).value = 0 And _
rngZelle.value = 1 And _
X <= cntAnzahl Then
strAusgabe(X) = rngZelle.Offset(, -1).value
X = X + 1
End If
Next rngZelle
LoadData = strAusgabe
End Function
Sub Test()
Dim sht As Worksheet, rng As Range, arr() As String
If ThisWorkbook.Worksheets("Loeschen") Is Nothing Then
Set sht = ActiveWorkbook.Worksheets.Add
sht.Name = "Loeschen"
End If
Set rng = Range("A1:A19")
arr = cls.LoadData
rng.value = arr
End Sub
This is the locals output when getting to the last row of code (rng.value = arr)
And this is what appears in my worksheet.
Related
I'm trying to copy multiple non-adjacent (non-contiguous) excel columns to an array but it's not working. Below is what I've tried...
Public Function Test()
Dim sh As Worksheet: Set sh = Application.Sheets("MyWorksheet")
Dim lr As Long: lr = sh.Cells(sh.Rows.Count, 1).End(xlUp).row
Dim r1 As Range: Set r1 = sh.Range("A1:A" & lr)
Dim r2 As Range: Set r2 = sh.Range("C1:C" & lr)
Dim rAll As Range: Set rAll = Union(r1, r2)
'Dim arr() As Variant: arr = Application.Transpose(rAll) <-- Throws Type mismatch error
'Dim arr As Variant: arr = Application.Transpose(rAll) <-- arr Value = Error 2015
Dim arr() As Variant: arr = rAll.Value2 ' <-- Only the first column (col A) is loaded.
End Function
Any help is greatly appreciated!
Since reading multiple values into an array like arr = rAll.Value2 is only possible in continous ranges, you have to alternatives:
Alternative 1:
Write a function that reads the range values area wise and merge it into one array.
Option Explicit
Public Function NonContinousColumnsToArray(ByVal NonContinousRange As Range) As Variant
Dim iArea As Long
For iArea = 1 To NonContinousRange.Areas.Count - 1
If NonContinousRange.Areas.Item(iArea).Rows.CountLarge <> NonContinousRange.Areas.Item(iArea + 1).Rows.CountLarge Then
MsgBox "Different amount of rows is not allowed.", vbCritical, "NonContinousColumnsToArray"
Exit Function
End If
Next iArea
Dim ArrOutput() As Variant
ArrOutput = NonContinousRange.Value2 'read first area into array
'read all other areas
For iArea = 2 To NonContinousRange.Areas.Count
ReDim Preserve ArrOutput(1 To UBound(ArrOutput, 1), 1 To UBound(ArrOutput, 2) + NonContinousRange.Areas.Item(iArea).Columns.CountLarge) As Variant 'resize array
Dim ArrTemp() As Variant 'read arrea at once into temp array
ArrTemp = NonContinousRange.Areas.Item(iArea).Value2
'merge temp array into output array
Dim iCol As Long
For iCol = 1 To UBound(ArrTemp, 2)
Dim iRow As Long
For iRow = 1 To UBound(ArrTemp, 1)
ArrOutput(iRow, UBound(ArrOutput, 2) - UBound(ArrTemp, 2) + iCol) = ArrTemp(iRow, iCol)
Next iRow
Next iCol
Next iArea
NonContinousColumnsToArray = ArrOutput
End Function
So the following example procedure
Public Sub ExampleTest()
Dim InputRng As Range
Set InputRng = Union(Range("A1:A9"), Range("C1:D9"))
Dim OutputArr() As Variant
OutputArr = NonContinousColumnsToArray(InputRng)
Range("A12").Resize(UBound(OutputArr, 1), UBound(OutputArr, 2)).Value = OutputArr
End Sub
would take the following non-continous range Union(Range("A1:A9"), Range("C1:D9")) as input,
Image 1: The input range was non-continous A1:A9 and C1:D9.
merge it into one array OutputArr and write the values as follows
Image 2: The merged output array written back into cells.
Alterantive 2: Using a temporary worksheet …
… to paste the values as continous range, which then can be read into an array at once.
Public Sub ExampleTestTempSheet()
Dim InputRng As Range
Set InputRng = Union(Range("A1:A9"), Range("C1:D9"))
Dim OutputArr() As Variant
OutputArr = NonContinousColumnsToArrayViaTempSheet(InputRng)
Range("A12").Resize(UBound(OutputArr, 1), UBound(OutputArr, 2)).Value = OutputArr
End Sub
Public Function NonContinousColumnsToArrayViaTempSheet(ByVal NonContinousRange As Range) As Variant
On Error Resume Next
NonContinousRange.Copy
If Err.Number <> 0 Then
MsgBox "Different amount of rows is not allowed.", vbCritical, "NonContinousColumnsToArray"
Exit Function
End If
On Error GoTo 0
Dim TempSheet As Worksheet
Set TempSheet = ThisWorkbook.Worksheets.Add
TempSheet.Range("A1").PasteSpecial xlPasteValues
Application.CutCopyMode = False
NonContinousColumnsToArrayViaTempSheet = TempSheet.UsedRange.Value2
Dim ResetDisplayAlerts As Boolean
ResetDisplayAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
TempSheet.Delete
Application.DisplayAlerts = ResetDisplayAlerts
End Function
Note that the alternative 2 is more likely to fail, because of the temporary worksheet. I think alternative 1 is more robust.
Alternative solution via Application.Index() function
Just for fun an alternative solution allowing even a resorted column order A,D,C:
Sub ExampleCall()
'[0]define range
With Sheet1 ' reference the project's source sheet Code(Name), e.g. Sheet1
Dim lr As Long: lr = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim rng As Range: Set rng = .Range("A1:D" & lr)
End With
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'[1]get data in defined columns order A,C,D
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim data: data = RearrangeCols(rng, "A,D,C")
'[2]write to any target range
Sheet2.Range("F1").Resize(UBound(data), UBound(data, 2)) = data
End Sub
Help functions called by above main procedure
Function RearrangeCols(rng As Range, ByVal ColumnList As String)
'Purpose: return rearranged column values based on ColumnList, e.g. Columns A,C,D instead of A:D
'[a]assign data to variant array
Dim v: v = rng
'[b]rearrange columns
v = Application.Index(v, Evaluate("row(1:" & UBound(v) & ")"), GetColNums(ColumnList)) ' Array(1, 3, 4)
'[c]return rearranged array values as function result
RearrangeCols = v
End Function
Function GetColNums(ByVal ColumnList As String, Optional ByVal Delim As String = ",") As Variant()
'Purpose: return array of column numbers based on argument ColumnList, e.g. "A,C,D" ~> Array(1, 3, 4)
'[a]create 1-dim array based on string argument ColumnList via splitting
Dim cols: cols = Split(ColumnList, Delim)
'[b]get the column numbers
ReDim tmp(0 To UBound(cols))
Dim i: For i = 0 To UBound(tmp): tmp(i) = Range(cols(i) & ":" & cols(i)).Column: Next
'[c]return function result
GetColNums = tmp
End Function
Further solution //Edit as of 2020-06-11
For the sake of completeness I demonstrate a further solution based on an array of arrays (here: data) using the rather unknown double zero argument in the Application.Index() function (see section [2]b):
data = Application.Transpose(Application.Index(data, 0, 0))
Sub FurtherSolution()
'[0]define range
With Sheet1 ' reference the project's source sheet Code(Name), e.g. Sheet1
Dim lr As Long: lr = .Cells(.Rows.Count, 1).End(xlUp).Row
Dim rng As Range: Set rng = .Range("A1:D" & lr)
End With
'[1]assign data to variant array
Dim v: v = rng
'[2]rearrange columns
'a) define "flat" 1-dim array with 1-dim column data A,C,D (omitting B!)
Dim data
data = Array(aCol(v, 1), aCol(v, 3), aCol(v, 4))
'=====================
'b) create 2-dim array
'---------------------
data = Application.Transpose(Application.Index(data, 0, 0))
'[3]write to any target range
Sheet2.Range("F1").Resize(UBound(data), UBound(data, 2)) = data
End Sub
Function aCol(DataArr, ByVal colNo As Long) As Variant()
'Purpose: return entire column data as "flat" 1-dim array
With Application
aCol = .Transpose(.Index(DataArr, 0, colNo))
End With
End Function
Caveat: This 2nd approach seems to be less performant for greater data sets.
Related link
Some pecularities of the Application.Index() function
Thank you PEH,
Great explanation which led me to the following solution:
Function Test()
Dim sh as Worksheet : set sh = Sheets("MySheet")
Dim lr as Long : lr = sh.Cells(sh.Rows.Count, 1).End(xlUp).row
Dim arr () as Variant
Dim idx as Long
' Delete unwanted columns to ensure contiguous columns...
sh.Columns("B:B").Delete
' Load Array
arr = Sheet("MySheet").Range("A1:B" & lr).value2
' This allows speedy index finds... Note, index(arr, startrow, keycol)
' Will need to use "On Error" to handle key not being found
idx = WorksheetFunction.match("MyKey", WorksheetFunction.Index(arr, 0, 2), 0)
' And then fast processing through the array
For idx = idx to lr
if (arr(idx, 2) <> "MyKey") then exit for
' do some processing...
Next idx
End Function
Thank you again!
The idea behind using arrays is to increase speed. Moving and deleting columns, as well as "for" looping slows you down.
I'm looking for a way to speed up one of my procedures from 120,000 µs to 60,000 or less.
The proposed solutions slow it down to 450,000.
I'm trying to run through a column of values, compare it to a supplied string, if it matches the string, add the value 4 columns over into an array, then sum the array at the end of the function.
The function exits out (not fails) at the ReDim Preserve line.
If I comment that out, it fails at the SumArray(Count) line.
What am I missing?
'Function used to SUM
Public Function TotalSum(prefix As String, rng As Range) As Integer
Dim BookofDaveSum As Dictionary
Set BookofDaveSum = New Dictionary
Dim SumArray As Variant
Dim Count As Long
Dim cell As Range
Dim i As Integer
Count = 0
For Each cell In rng
If Left(cell.Value, 7) = prefix Then
If Not BookofDaveSum.Exists(cell.Value2) Then
BookofDaveSum.Add cell.Value2, 0
ReDim Preserve SumArray(0 To Count)
SumArray(Count) = cell.Offset(0, 4)
Count = Count + 1
End If
End If
Next cell
TotalSum = Application.WorksheetFunction.Sum(SumArray)
End Function
Since you are iterating the range you are not gaining anything by using the array. Simply keep a running total:
Public Function TotalSum(prefix As String, rng As Range) As Integer
Dim BookofDaveSum As Dictionary
Set BookofDaveSum = New Dictionary
Dim cell As Range
For Each cell In rng
If Left(cell.Value, 7) = prefix Then
If Not BookofDaveSum.Exists(cell.Value2) Then
TotalSum = TotalSum + cell.Offset(0, 4).Value2
End If
End If
Next cell
End Function
If your concern is speed then convert both ranges to arrays and iterate the array:
Public Function TotalSum(prefix As String, rng As Range) As Long
Dim BookofDaveSum As Dictionary
Set BookofDaveSum = New Dictionary
Dim chRng As Variant
chRng = rng.Value2
Dim addRng As Variant
addRng = rng.Offset(, 4).Value2
Dim temp As Long
temp = 0
Dim i As Long
For i = LBound(chRng, 1) To UBound(chRng, 1)
If Left(chRng(i, 1), 7) = prefix Then
If Not BookofDaveSum.Exists(chRng(i, 1)) Then
temp = temp + addRng(i, 1)
End If
End If
Next cell
TotalSum = temp
End Function
Also this can be done with a formula:
=SUMPRODUCT(((LEFT(A1:A10,7)="abcdefg")*(E1:E10))/(COUNTIFS(A1:A10,A1:A10,A1:A10,"abcdefg" &"*")+(LEFT(A1:A10,7)<>"abcdefg")))
Where abcdefg is your prefix, A1:A10 is the string to test and E1:E10 the values to add
Dim SumArray() As Variant you are trying to redim a variable not an array. () indicates you want an array of variants.
I have a column with different values. I have to select only unique values from the column and put in an array.
I am using following code for the same but it puts unique values in another column rather array.
Sub GetUniqueSections()
Dim d As Object, c As Variant, i As Long, lastRow As Long
Dim a(8) As String
Dim j
Set d = CreateObject("Scripting.Dictionary")
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
c = Range("C2:C" & lastRow)
For i = 1 To UBound(c, 1)
d(c(i, 1)) = 1
Next i
Range("R2").Resize(d.Count) = Application.Transpose(d.Keys)
End Sub
In the code below, UniqueValueArrayFromRange replaces your GetUniqueSections using the same technique with a Scripting.Dictionary. You can substitute "A1:A14" with whatever you need and the output array will be in arr:
Option Explicit
Sub Test()
Dim rng As Range
Dim arr As Variant
Dim i As Integer
' pass range values to function for unique values
Set rng = Sheet1.Range("A1:A14")
arr = UniqueValueArrayFromRange(rng)
' test return values
For i = LBound(arr) To UBound(arr)
Debug.Print arr(i)
Next i
End Sub
Function UniqueValueArrayFromRange(ByRef rngSource As Range) As Variant
Dim dic As Object
Dim rngCell As Range
' create dictionary and only add new values
Set dic = CreateObject("Scripting.Dictionary")
For Each rngCell In rngSource
If Not dic.Exists(rngCell.Value) Then
dic.Add rngCell.Value, 1
End If
Next rngCell
' return key collection as array
UniqueValueArrayFromRange = dic.Keys
End Function
Thank you for all of the help. I have successfully populated and reviewed the contents of my array. Now I am having trouble calling the specific instances (string values) within the array in a function I wrote to compare cells in the sheet to the values in the array....
I am getting the "subscript out of range" inside of my function in my strcomp(). I have checked and the right value is being passed via vCompare.
Arrays are so finicky!
Here is the updated code:
Sub searchTrucks()
Dim lastRow As Long
Dim EndRow As Long
Dim showAll As Boolean
Dim BeginRow As Long
Dim RowCnt As Long
Dim chckTech As Long
Dim chckReg As Long
Dim chckSite As Long
Dim chckUnum As Long
Dim chckType As Long
Dim chckAge As Long
Dim chckDt As Long
Dim chckCap As Long
Dim i As Integer
Dim aRan As Range
Dim bRan As Range
Dim cRan As Range
Dim rrRan As Range
Dim rmRan As Range
Dim marray() As Variant
marray = WorksheetFunction.Transpose(Worksheets("Calculations").Range("F2:K2"))
Dim vCompare As String
Dim x As Long
Dim y As Long
y = 2
x = 1
i = 1
lastRow = Application.CountA(Sheets("Trucks").Range("C:C"))
BeginRow = 6
EndRow = lastRow + 4
chckSite = 3
chckUnum = 4
chckType = 5
chckAge = 7
chckDt = 10
chckCap = 11
Debug.Print lastRow
For i = 1 To 8
If IsEmpty(Sheets("Trucks").Cells(2, i).Value) Then
showAll = True
Else
showAll = False
Exit For
End If
Next i
Debug.Print showAll
If showAll = False Then
For RowCnt = BeginRow To EndRow
If Not IsEmpty(Sheets("Trucks").Cells(2, 3).Value) And IsEmpty(Sheets("Trucks").Cells(2, 4).Value) Then
For y = 2 To 6
If Sheets("Trucks").Cells(2, 3).Value = Sheets("Calculations").Cells(y, 5).Value Then
vCompare = Sheets("Trucks").Cells(RowCnt, chckSite).Value
If IsInArray(vCompare, marray) = -1 Then
Cells(RowCnt, chckSite).EntireRow.Hidden = True
End If
End If
Next
Stop
End If
If Not IsEmpty(Sheets("Trucks").Cells(2, 4).Value) And Sheets("Trucks").Cells(RowCnt, chckSite).Value <> Sheets("Trucks").Cells(2, 4).Value Then
Cells(RowCnt, chckSite).EntireRow.Hidden = True
ElseIf Not IsEmpty(Sheets("Trucks").Cells(2, 5).Value) And Sheets("Trucks").Cells(RowCnt, chckUnum).Value <> Sheets("Trucks").Cells(2, 5).Value Then
Cells(RowCnt, chckUnum).EntireRow.Hidden = True
ElseIf Not IsEmpty(Sheets("Trucks").Cells(2, 6).Value) And Sheets("Trucks").Cells(RowCnt, chckType).Value <> Sheets("Trucks").Cells(2, 6).Value Then
Cells(RowCnt, chckType).EntireRow.Hidden = True
ElseIf Not IsEmpty(Sheets("Trucks").Cells(2, 7).Value) And Sheets("Trucks").Cells(RowCnt, chckAge).Value < Sheets("Trucks").Cells(2, 7).Value Then
Cells(RowCnt, chckAge).EntireRow.Hidden = True
ElseIf Not IsEmpty(Sheets("Trucks").Cells(2, 9).Value) And Sheets("Trucks").Cells(RowCnt, chckDt).Value < Sheets("Trucks").Cells(2, 9).Value Then
Cells(RowCnt, chckDt).EntireRow.Hidden = True
ElseIf Not IsEmpty(Sheets("Trucks").Cells(2, 10).Value) And Sheets("Trucks").Cells(RowCnt, chckCap).Value < Sheets("Trucks").Cells(2, 10).Value Then
Cells(RowCnt, chckCap).EntireRow.Hidden = True
End If
Next RowCnt
Else
Sheets("Trucks").Cells.EntireRow.Hidden = False
End If
Here is my function code:
Function IsInArray(stringToBeFound As String, arr As Variant) As Long
Dim i As Long
' default return value if value not found in array
IsInArray = -1
Debug.Print stringToBeFound
For i = LBound(arr) To UBound(arr)
If StrComp(stringToBeFound, arr(i), vbTextCompare) = 0 Then
IsInArray = i
Exit For
End If
Next i
End Function
To populate your arrays you can do this
Dim aArray As Variant
aArray = WorksheetFunction.Transpose(Worksheets("Calculations").Range("F2:K2"))
And similarly for all the rest of your arrays.
You cannot use debug.print on arrays. Instead, in your VBA editor right-click on the variable name (aArray) and select "Add watch". Your variable will appear in the "Watches" window. Now add a break-point just after you (correctly) populate aArray in the code and run your code. It will stop at the break-point and you can now go into the "Watches" window and expand the aArray variable. You will see the contents of the array here.
Regarding the use of the Array function, see here - a comma delimited list of items is required. It is often used to do quick-and-dirty creation of variant arrays, often for static data consisting of small lists. For instance, things like Array("Jan", "Feb", "Mar",...,"Dec")... stuff like that.
You generally do not need to call this constructor explicitly when using arrays. For simple non-Variant data types an array of type X is defined like so:
dim an_X_array(10) as X
This defines an_X_array to be an array of 10 items that each have type X
Compare this to a simple variable defined to be of type X
dim an_X as X
With regards to your second problem - it is being caused by the array you create from your range (worksheet data) being constructed as a 2-dimensional array. You can either work with 2-dimensional arrays, and change your formulas, or use the below helper function to create a 1-dimensional array from your worksheet data. Here is the function to create a proper 1-dimensional array from any worksheet range (just copy-paste it somewhere in your code module):
Public Function RngToArray(ByRef InputRange As Range) As Variant
Dim A As Variant
Dim rr As Range
Dim i As Long
ReDim A(InputRange.Cells.Count)
i = LBound(A)
For Each rr In InputRange
A(i) = rr.Value
i = i + 1
Next
ReDim Preserve A(i - 1)
RngToArray = A
End Function
And for your example you then need to replace just one line of your code:
change
marray = WorksheetFunction.Transpose(Worksheets("Calculations").Range("F2:K2"))
to
marray = RngToArray(Worksheets("Calculations").Range("F2:K2"))
the way you populate your array , you will get a 2 dimensional array, so i modified your source code to test if your value is in the array :
Function IsInArray( Byval stringToBeFound As String, Byref arr As Variant) As Long
Dim i As Long 'i is the columns variable
Dim J& 'j is the rows variable
' default return value if value not found in array
IsInArray = -1
Debug.Print stringToBeFound
For i = LBound(arr,2) To UBound(arr,2) 'the ,2 is to say the 2nd dimension (same order of dimensions as if you'd use the cells function)
For j = LBound(arr,1) To UBound(arr,1)
If stringToBeFound = arr(j,i) Then 'simple test of strings
IsInArray = i 'will give the column as answer
Exit Function 'Exit For
End If
Next i
End Function
I have a function that fills a certain array with cell values depending on which OptionButton is selected. How would I reference those same arrays in a seperate function which would feed those values back into the cells? Here is my (working) code so far.
Private Sub CommandButton1_Click()
Dim wave1Array(0 To 30) As String
Dim wave2Array(0 To 30) As String
Dim wave3Array(0 To 30) As String
Dim wave4Array(0 To 30) As String
Dim wave5Array(0 To 30) As String
Dim rng As Range
Dim cell As Range
Dim counter As Long
Set rng = Range("B2", "AF2")
counter = 0
If OptionButton6.Value = True Then
For Each cell In rng
wave1Array(counter) = cell.Value
counter = counter + 1
Next cell
ElseIf OptionButton7.Value = True Then
For Each cell In rng
wave2Array(counter) = cell.Value
counter = counter + 1
Next cell
ElseIf OptionButton8.Value = True Then
For Each cell In rng
wave3Array(counter) = cell.Value
counter = counter + 1
Next cell
ElseIf OptionButton9.Value = True Then
For Each cell In rng
wave4Array(counter) = cell.Value
counter = counter + 1
Next cell
ElseIf OptionButton10.Value = True Then
For Each cell In rng
wave5Array(counter) = cell.Value
counter = counter + 1
Next cell
End If
End Sub
You have a few different options that I can think of.
As others have mentioned, make a module-level variable(s) as needed. These declarations should go in the same code module as your form controls. If the form controls are on a userform, then they should be declared in the form's code module, not a "standard" module.
'-------------------------------- all in the same code module -------------
Option Explicit
Dim myVariable as String
Private Sub CommandButton1_Click()
myVariable = "Hello, world!"
End Sub
Private Sub CommandButton2_Click()
msgBox myVariable
End Sub
'------------------------------- end of this example ----------------------
Public/GLobal variable may be an option but I recall there are some limitations using these with UserForms, and since I'm not sure if you're using a UserForm, I won't recommend that.
A third option would be to pass the arguments from one procedure to another, but that usually only works with "chained" procedures/functions, like when one function calls another function and that does not seem to be what you're doing at all.
For your specific case:
You can also streamline your code to avoid using the counter and cell variables, using direct range-to-array assignment.
'Module-level array variables, accessible by other procedures in this module:
Dim wave1Array()
Dim wave2Array()
Dim wave3Array()
Dim wave4Array()
Dim wave5Array()
Dim wave6Array()
Private Sub CommandButton1_Click()
Dim rng As Range
Dim arr()
Set rng = Range("B2", "AF2")
'## Converts the row to an array (0 to 30)
arr = Application.Transpose(Application.Transpose(rng.Value))
'## Assigns the array from above to one of the module-level array variables:
If OptionButton6.Value = True Then wave1Array = arr
If OptionButton7.Value = True Then wave2Array = arr
If OptionButton8.Value = True Then wave3Array = arr
If OptionButton9.Value = True Then wave4Array = arr
If OptionButton10.Value = True Then wave5Array = arr
If OptionButton11.Value = True Then wave6Array = arr
End Sub
Note that to do this, you will have to declare them as variant arrays, since a range of cells .Value is a variant type (cells can contain error values which I believe will fail if you try to assign to a string array).
IF you must use strict String arrays, then you will need to use the counter and cell iteration.