Dictionary value of key from another array - arrays

This has been answered... have to wait 2 days to accept own answer
Background:
I have an array ("arr") generated from a dataset in Excel; I use that array to populate another array ("zrr"), where one aspect of that population is to use a Dictionary ("dcdept").
The dictionary was populated appropriately (tested via debug.print dcdept(ActualKey); was populated such that dcdept(4000)="Value" and tested debug.print dcdept(4000) printed the word "Value" in the immediate window.
I was originally using the source dataset via .cells(i,) references, but with several hundred thousand lines, I tried to keep activities in VBA to speed it up.
There are no errors/alerts generated from my code.
Issue:
When attempting to populate an element in zrr (zrr(i-1,3)) using the dictionary key from arr (dcdept(arr(i-2,16))), I get no value output.
Question:
Does anyone have any suggestions/solutions to resolve the issue with the given data?
Code in question:
Public arr As Variant, brr As Variant, crr As Variant, drr As Variant, lrs As Long
Private Sub changes()
Dim i As Long, x As Long, y As String, z As String, dcdept As Scripting.Dictionary, zrr As Variant, a As Long
'set-up dictionary for department
Set dcdept = New Scripting.Dictionary
dcdept(4000) = "Value"
'generate array to store new values
With Sheets("Conversion")
.Columns(16).NumberFormat = "0"
lrs = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range(.Cells(2, 1), .Cells(lrs, 17)).Value '17 = Q
ReDim zrr(lrs, 4)
For i = 2 To lrs
ReDim Preserve zrr(lrs, 4)
Select Case Left(arr(i - 1, 17), 3)
Case "QTE"
x = 7
Case "ZNA"
x = 5
End Select
zrr(i - 2, 0) = Right(arr(i - 1, 17), x)
If InStr(arr(i - 1, 9), " Milestone ") Then
y = Left(arr(i - 1, 9), 2) & " " & arr(i - 1, 10)
Else
y = arr(i - 1, 9) & " " & arr(i - 1, 10)
End If
zrr(i - 2, 1) = y
If IsEmpty(arr(i - 1, 14)) Then
zrr(i - 2, 2) = "N"
Else
zrr(i - 2, 2) = "Y"
End If
a = Val(arr(i - 1, 16))
z = dcdept(a)
zrr(i - 2, 3) = z
Debug.Print a
Debug.Print z
Next i
'append data to sheet
.Cells(2, "R").Resize(lrs, 3).Value = zrr 'SHOULD BE Resize(lrs,4), per answer
End With
End Sub

OK this is not an answer, but an illustration of my comment. I didn't expect this to happen. I set up a simple scenario which I hope is similar to yours:
Sub x()
Dim oDic As Object, v1(1 To 2), v2(1 To 2), v, i As Long
Set oDic = CreateObject("Scripting.Dictionary")
v1(1) = "Fred"
v1(2) = 1000
oDic(1) = v1(1) 'key 1, item "Fred
oDic(2) = v1(2) 'key 2, item 1000
The locals window after this looks like this
Then add this line
v2(1) = oDic(v1(1))
and the immediate window reads thus:
Add this line
v2(2) = oDic(v1(2))
and the immediate window reads thus:

I'm an idiot...
.Cells(2, "R").Resize(lrs, 3).Value = zrr
should be
.Cells(2, "R").Resize(lrs, 4).Value = zrr
Can't accept my own answer for 2 days; pardon the "unanswered" question in the meantime.

Related

VBA will not pass array to sub

I am trying to pass 3 values to the 2nd sub, the name of the "channel" every 3 columns are a different data set with a different name. "Test" which is the names of the test file to extract the channels from that data and create graphs from it.
Sub PickTests()
Dim Channame() As String
Dim Amplitude() As String
Dim Integration() As String
Dim LvlCross() As String
Dim MaxAnal() As String
Dim Chans As Double
Dim x As Long
Dim TestList() As Double
Dim i As Long
Worksheets("Channel_List.csv").Activate
For i = 1 To (Cells(i + 2, 1).Value = 0)
Channame(i) = Cells(i + 1, 1)
Amplitude(i) = Cells(i + 1, 2)
Integration(i) = Cells(i + 1, 3)
LvlCross(i) = Cells(i + 1, 4)
MaxAnal(i) = Cells(i + 1, 5)
Chans = i + 1
Next i
Worksheets("HomeSheet").Activate
' Set numrows = number of rows of data.
NumRows = Range("A14", Range("A14").End(xlDown)).Rows.Count
' Select cell a1.
Range("A4").Select
' Establish "For" loop to loop "numrows" number of times.
For x = 1 To NumRows
TestList(x) = Cells(x, 1).Value
ActiveCell.Offset(1, 0).Select
Next x
For i = 1 To Chans
If Amplitude(i) = y Then
AmplitudeDistribution(Channame(i), TestList)
End If
Next i
End Sub
Sub AmplitudeDistribution(Channame As String, Test() As Long)
Dim i, j, y, x As Long
Dim wsname As String
wsname = (Channame & "_Amp_Dist")
x = UBound(Test, 1) - LBound(Test, 1) + 1
Worksheets.Add.Name = wsname
Charts.Add
ActiveChart.ChartType = xlLineStacked
ActiveChart.Location Where:=wsname, Name:=Channame
For i = 1 To x
ActiveChart.SeriesCollection.NewSeries
Sheets(Test(i) & "_out_Amp_Dist.csv").Activate
With ActiveSheet
Set FindColumn = .Range("1:1").Find(What:=Channame, LookIn:=xlValues)
End With
y = FindColumn.Row
For j = 1 To (Cells(y, j + 1).Value = 0)
NumRow(i) = j
Next j
ActiveChart.SeriesCollection(i).Values = ActiveSheet.Range(Cells(y, 1), Cells(y + 1, j))
ActiveChart.SeriesCollection(i).Name = Channame
Next i
End Sub
I get an error type mismatch error trying to pass TestList to the 2nd sub. How can I get arround this?
Edit: Thank you everyone for your help, I come from a c++ background so didn't realise how dumb dynamic arrays are in VBA! All works perfectly now! (Well not all, but it passes everything to the 2nd sub, no i am just wrestling with charts....)
DisplayName saw it quick:
The array is declared here:
Dim TestList() As Double
And passed into here:
Sub AmplitudeDistribution(Channame As String, Test() As Long)
You're getting a type mismatch error, because the types.. mismatch. Change the parameter to an array of Double, or declare TestList() as an array of Long.
Or, just pass the array as a Variant:
Sub AmplitudeDistribution(Channame As String, Tests As Variant)
I'd use a plural name regardless of the type here, and since a Variant can wrap literally anything you might want to add a debugging safety net:
Debug.Assert IsArray(Tests) ' will break here if Tests isn't an array
You're declaring arrays, but these arrays are dynamically-sized, and unless you removed that code for posting, the arrays are never initialized, which means once you get the array into that parameter, the next error will be "index out of bounds" when you try to write TestList(x), or to read Test(i).
Use the ReDim statement to size your arrays:
ReDim TestList(1 To NumRows)
You'll need to do that for all arrays.
This is suspicious:
For i = 1 To (Cells(i + 2, 1).Value = 0)
The expression (Cells(i + 2, 1).Value = 0) is a Boolean expression, so you're looping i from 1 to 0 (False) or -1 (True), which means you're never entering that loop.

How to use nested loop for a Matrix cell in excel vba

Current Excel Sheet Structure
filteredStartRow = A2
detailsStartRow = D2
※i = x(get value for filteredItemCount, e.g: 2, 3, 2)
※j = y(get value for detailsItemCount, e.g: 4, 5, 3)
I am stuck, how efficiently I can move to second filteredStartRow (A4) and detailsStartRow (D10). and continue until the last filter and details StartRow.
What I am doing:
Get ItemCount (e.g: x, y) to run the nested loop within filter and details item.
Since I already know the next item count for filter and details, so I just need to change my NEXT filterStartRow and detailsStartRow.
How can construct my Loop using any dynamic settings for (i, j) as well as setting up STARTROW?
Can anyone please help with code.
Here is my code, which only works for the very first loop (green bordered).
startRow = 2
startRow1 = 2
nextDetailsRow = 0
For i = 1 To noOfFilteredItem (e.g:3)
mapFilteredItemCount = Worksheets("Sheet1").Cells(startRow, 3).Value
detailsItemCount = Worksheets("Sheet1").Cells(startRow1, 6).Value
With ThisWorkbook.Worksheets("Sheet1")
For m = 1 To mapFilteredItemCount
For n = 1 To detailsItemCount
If .Cells((startRow + m) - 1, 2) = .Cells((startRow1 + n) - 1, 5) Then
If IsEmpty(.Cells((startRow1 + n) - 1, 8).Value) = True Then
.Cells((startRow1 + n) - 1, 8).Value = "Deliver"
nextDetailsRow = nextDetailsRow + startRow + n
Else
GoTo NextIteration
End If
End If
NextIteration:
Next n
Next m
End With
Next i
My Problem is:
- I need to update the STARTROW and STARTROW1 dynamically once a loop (m, n) is completed.
- How can I assign STARTROW and STARTROW1 variable to receive next starting row value.
My Logic:
- I was thinking to keep all the STARTROW and STARTROW1 number into an array, then get value from the array.
for example:
filteredItemRowArray() = 2, 4, 7 (※starting row numbers for filtered item)
detailsItemRowArray() = 2, 6, 11 (※starting row numbers for details item)
but I could not arrange this array to keep row number values.
Could anyone please help me, I truly appreciate your programming SMARTNESS.
If you have any questions, or understanding problem, please let me know.
Thank you very much.
I would try the same idea. Looping through an array with the numbers. Please try the following code:
Sub Outer_Loop()
Dim StartrowArr, Startrow1Arr, I As Integer
Dim Startrow As Long, Startrow1 As Long
StartrowArr = Array(2, 4, 7)
Startrow1Arr = Array(2, 6, 11)
For I = LBound(StartrowArr) To UBound(StartrowArr)
Startrow = StartrowArr(I)
Startrow1 = Startrow1Arr(I)
Debug.Print "Loop " & I, "Startrow: " & Startrow, "Startrow1: " & Startrow1
' your code
Next I
End Sub

Determine Slope and Intercept using Dynamic Arrays VBA

Its been a while since I've used arrays in Excel VBA so please forgive me...
I'm trying to define a dynamic array based consecutive matching cells that are determined in a loop. I'm sure my syntax is wrong for defining the arrays I'm just not sure how. The difficulty is that my array consists of about 6 consecutive rows in 1 column, plus another cell in a different column. Any ideas?
Sub calib_range()
Dim instrument As Variant
Dim calibrator As Variant
Dim lastrow As Integer
lastrow = ThisWorkbook.ActiveSheet.Range("b2").SpecialCells(xlCellTypeLastCell).Row
For i = 4 To lastrow
If Cells(i, 4) Like "MPC*" Then
'enter loop to determine length of MPC* array
For x = i + 1 To lastrow
If Cells(x, 4) = Cells(x - 1, 4) Then
Else
x = x - 1
Exit For
End If
Next x
instrument = Array(Cells(i, 17), Range(Cells(i, 14), Cells(x, 14)))
calibrator = Array(0, Range(Cells(i, 12), Cells(x, 12)))
Slope = Application.WorksheetFunction.Slope(instrument, calibrator)
Intercept = Application.WorksheetFunction.Intercept(instrument, calibrator)
Cells(i, 22) = Slope
Cells(i, 23) = Intercept
End If
Next i
End Sub
Your problem is here:
calibrator = Array(0, Range(Cells(i, 12), Cells(x, 12)))
You are not allowed to do so, because VBA thinks that in your array you get a 0 and a range. Thus, your array consists of two different types of valuse. Which is not what you need.
Read here a little more about how to initialize arrays, it is well explained.
Edit:
Also on the previous line you simply make an array of ranges. What would work out for you is probably something like this:
Public Sub CheckArray()
Dim my_array() As Double
ReDim my_array(6)
my_array(0) = Cells(1, 17)
my_array(1) = Cells(2, 17)
my_array(2) = Cells(3, 17)
my_array(3) = Cells(4, 17)
my_array(4) = Cells(5, 17)
my_array(5) = Cells(6, 17)
my_array(6) = Cells(7, 17)
End Sub

VBA Macro Speed Up

I would appreciate some help on the following VBA Macro problem,
screenshot here:
I have to compare the data in 2 columns - Index & Sec_Index. In case of a match it should check which Values is assigned to the Sec_Index and fill a "1" to the matching Value column corresponding to Index and "0" for the other Value columns (I hope the screenshot explains it better)
I wrote a short macro which works good. However I have huge amounts of data - both Index columns contain at least 400000-500000 lines. This makes my code useless since it will take extreme long durations to execute.
Is there a way to make this work? I read about Variant arrays, but I'm not that familiar with them.
You can put this formula (if Excel 2007 or above):
=COUNTIFS($H$2:$H$5,$B2,$I$2:$I$5,"A")
into C2 and copy it down and across; just change "A" to "B" and "C".
Added In view of the number of rows, I would import the data into MS Access, create a Crosstab Query, then copy this data back to Excel.
You can do this with a formula. Something like:
=IF(AND(LOOKUP($B2,$H$2:$H$6,$I$2:$I$6)="A",LOOKUP($B2,$H$2:$H$6,$H$2:$H$6)=B2),1,0)
replacing "B" and "C".
Try this, not overly robust but does work. Not sure how quickly this will compare to what you may have had?
It did about 60,000 rows with 25 keys in about 5 seconds.
Edit: Added timer to function.
Public Declare Function GetTickCount Lib "kernel32.dll" () As Long
public Sub main()
Dim t As Long
t = GetTickCount
Application.ScreenUpdating = False
Dim Arr1(), Arr() As Double
Dim x, y, i, j As Double
Dim v As String
x = Cells(Rows.Count, 2).End(xlUp).Row - 2
y = Cells(Rows.Count, 8).End(xlUp).Row - 2
Range("c2", "e" & x + 2) = 0
ReDim Arr1(x)
ReDim Arr2(y)
i = 0
Do Until Cells(i + 2, 2) = ""
Arr1(i) = Cells(i + 2, 2)
i = i + 1
Loop
i = 0
Do Until Cells(i + 2, 8) = ""
Arr2(i) = Cells(i + 2, 2)
i = i + 1
Loop
i = 0
Do Until i > UBound(Arr1)
j = 0
Do Until j > UBound(Arr2)
If Arr1(i) = Arr2(j) Then
v = Cells(Arr2(j) + 1, 9)
Select Case v
Case "a"
Cells(i + 2, 3) = 1
Case "b"
Cells(i + 2, 4) = 1
Case "c"
Cells(i + 2, 5) = 1
End Select
Exit Do
End If
j = j + 1
Loop
i = i + 1
Loop
MsgBox GetTickCount - t, , "Milliseconds"
End Sub

Excel Macro Multi Dimension Array Value Deleted after IF function

I met with some problem with Excel Macro.
I am trying too copy values from various cells of a worksheet into an array for use of comparing with other worksheet's cell value later.
However, I am stuck at the array to store all the value I am trying to assign to it.
Below is the code piece I have done.
Sub singleEntry(suppRow As Integer)
Dim j As Integer
Dim myArray() As Variant
Dim a As Integer
Dim b As Integer
Dim c As Integer
Worksheets("Ind. Supp. Plan Time").Select
Cells(suppRow, "I").Select
For j = 9 To 13
c = j - 8
ReDim myArray(5, 4) As Variant
myArray(c, 1) = c
'ReDim Preserve myArray(5, 4) As Variant
If Cells(suppRow, j).Value = "*" Then
ReDim Preserve myArray(5, 4) As Variant
'myArray(j - 8, 1) = j - 8
myArray(j - 8, 2) = Cells(suppRow, "P").Value
myArray(j - 8, 3) = Cells(suppRow, "Q").Value
myArray(j - 8, 4) = Cells(suppRow, "R").Value
MsgBox "array = {" & myArray(c - 1, 2) & "}"
Else
ReDim Preserve myArray(5, 4) As Variant
myArray(j - 8, 2) = "1"
myArray(j - 8, 3) = "1"
myArray(j - 8, 4) = "1"
MsgBox "array(1,3) = {" & myArray(1, 3) & "}"
End If
Next j
ReDim Preserve myArray(5, 4) As Variant
'For a = 1 To 5
' For b = 1 To 4
' MsgBox "Array = {" & myArray(a, b) & "}"
' Next b
'Next a
End Sub
I put in MsgBox to view the result of executing the code, I am sure the lines are executed as expected.
If I print the value of the array straight away after assign one value to it, the value printed is correct.
However, now I can't solve this problem.
Hopefully anyone know this can give me a help.
Thank you very much!
Not sure why you can't retrieve values. I tested this and it works.
Sub singleEntry(suppRow As Integer)
Dim arrStore(1 To 5, 1 To 4) As Variant, col As Integer, r As Integer, c As Integer
Worksheets("Ind. Supp. Plan Time").Select
For col = 9 To 13
arrStore(col - 8, 1) = col - 8
arrStore(col - 8, 2) = IIf(Cells(suppRow, col) = "*", Cells(suppRow, "P"), 1)
arrStore(col - 8, 3) = IIf(Cells(suppRow, col) = "*", Cells(suppRow, "Q"), 1)
arrStore(col - 8, 4) = IIf(Cells(suppRow, col) = "*", Cells(suppRow, "R"), 1)
Next col
For r = 1 To 5
For c = 1 To 4
Debug.Print arrStore(r, c)
Next c
Next r
End Sub
Points to note:
Given that you always fill the array there is no need to ReDim. It's redundant (and expensive)
I've used the ternary IIF statement to tidy up the code i.e. if "*" then x else 1
I don't think you need the variable c so I've removed it
I've added a simple loop at the end to print out the array (which works for me)
Does this solve it?

Resources