Dictionary is empty after declaring it and populating - vba

I'm not so good with VBA, thus I'm suspecting an issue with declaring and later on using the dictionary.
I've taken a different approach. Created two functions to creat the dicts.
The for loop first is checking if the Control in userform is textbox, than is getting column number (dict_col) and checks if needs to be formatted as date (dict_for).
However each time the second dict seems to be empty... When I check content of each dict separately (before the loop), it shows correct values.
Public Function import_columns(rng As Variant) As Dictionary
Dim dict As New Dictionary
Dim i As Long
Dim count_rows As Long
Dim dict_k As String, dict_i As String
count_rows = rng.Rows.Count
For i = 1 To count_rows
dict_k = rng(i, 2)
dict_i = rng(i, 1)
dict.Add dict_k, dict_i
Next i
Set import_columns = dict
End Function
Public Function import_format(rng As Variant) As Dictionary
Dim dict_f As New Dictionary
Dim i As Long
Dim count_rows As Long
count_rows = rng.Rows.Count
For i = 1 To count_rows
dict_f(rng(i, 1)) = 0
Next i
Set import_format = dict_f
End Function
Private Sub UserForm_Initialize()
'On Error GoTo ErrorHandle
Dim wb As Workbook
Dim rng_col As Range
Dim rng_format As Range
Dim dc_value As Integer
Dim ctrl As Control
Dim ctrlType As String
Dim ctrl_name As String
Dim key As Variant
Dim dict_col As Dictionary
Dim dict_for As Dictionary
Set rng_col = Application.Union(Range("columns_mark").Columns(3), Range("columns_mark").Columns(2))
Set rng_format = Arkusz25.Range("H1").CurrentRegion
Set dict_col = import_columns(rng_col)
Set dict_for = import_format(rng_format)
'Me.Results.Enabled = False
ListBox1.RowSource = "lista"
txt_results = ListBox1.ListCount
For Each key In dict_col.Keys
'If dict_col.Exists(key) Then
Debug.Print key
Debug.Print dict_col(key)
'End If
Next key
ctrlType = "TextBox"
For Each ctrl In Results.Controls
ctrl_name = ctrl.Name
If TypeName(ctrl) = ctrlType Then
dc_value = dict_col(ctrl_name)
If dict_for.Exists(ctrl_name) Then
ctrl = Format(Val(ListBox1.List(0, dc_value - 1)), "dd.mm.yyyy")
Else
ctrl = ListBox1.List(0, dc_value - 1)
End If
ctrl.Enabled = False
End If
Next ctrl

Related

Why are public variables lost after an error?

I have developed the following two subs which create and remove a collection of checkboxes next to a listobject. Each distinct ID in the listobject gets a checkbox. Like this I can approve the listobject entries.
The code is the follwing:
Public CBcollection As Collection
Public CTRLcollection As Collection
Sub create_chbx()
If Approval.CBcollection Is Nothing Then
Dim i As Integer
Dim tbl As ListObject
Dim CTRL As Excel.OLEObject
Dim CB As MSForms.CheckBox
Dim sht As Worksheet
Dim L As Double, T As Double, H As Double, W As Double
Dim rng As Range
Dim ID As Long, oldID As Long
Set CBcollection = New Collection
Set CTRLcollection = New Collection
Set sht = ActiveSheet
Set tbl = sht.ListObjects("ApprovalTBL")
Set rng = tbl.Range(2, 1).Offset(0, -1)
W = 10
H = 10
L = rng.Left + rng.Width / 2 - W / 2
T = rng.Top + rng.Height / 2 - H / 2
For i = 1 To tbl.ListRows.count
ID = tbl.Range(i + 1, 1).Value
If Not (ID = oldID) Then
Set CTRL = sht.OLEObjects.Add(ClassType:="Forms.CheckBox.1", Link:=False, DisplayAsIcon:=False, Left:=L, Top:=T, Width:=W, Height:=H)
Set CB = CTRL.Object
CBcollection.Add Item:=CB
CTRLcollection.Add Item:=CTRL
End If
Set rng = rng.Offset(1, 0)
T = rng.Top + rng.Height / 2 - H / 2
oldID = ID
Next i
End If
End Sub
Sub remove_chbx()
If Not Approval.CBcollection Is Nothing Then
With Approval.CBcollection ' Approval is the module name
While .count > 0
.Remove (.count)
Wend
End With
With Approval.CTRLcollection
While .count > 0
.Item(.count).Delete
.Remove (.count)
Wend
End With
Set Approval.CBcollection = Nothing
Set Approval.CTRLcollection = Nothing
End If
End Sub
This all works pretty well. No double checkboxes and no errors if there are no checkboxes. I am developing an approval scheme were I need to develop and test other modules. If I now run this sub:
Sub IdoStupidStuff()
Dim i As Integer
Dim Im As Image
i = 1
Set Im = i
End Sub
It will give me an error. If I then try to run one of my checkbox subs they will not work properly anymore. The collection is deleted by the error and I am no longer able to access the collections. Why does this happen and am I able to counter act this other then just not causing errors? Is there a better way to implement such a system were loss of collections is not an issue?
You could wrap the Collection object in a Property and let it handle the object creation:
Private mCollection As Collection
Public Property Get TheCollection() As Collection
If mCollection Is Nothing Then Set mCollection = New Collection
Set TheCollection = mCollection
End Property
To call it:
TheCollection.Count
Try On Error Resume Next before the line that causes the error. It will skip the problem and your vairables will still be available.
However this will not solve your error. Try to make a seperate hidden sheet in your workbook to store your global variables so they won't go missing.
f.ex.:
Private Sub CreateSheet()
Dim ws As Worksheet
With ThisWorkbook
Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
ws.Name = "Global"
.Worksheets("Global").Visible = False
End With
End Sub

Vba Dictionary Result Don`t Return Correctly

I was trying to use dictionary to lookup value in column F
with key in column C.
But after the result dont return like I want. It show "0"
Scenario:
1. key in column C will have mutliple same value
2. I want to sum up all the value in column F based on key and return to "RAW" Range("C2")
"Sheet2"
"RAW"
Please help me.
Thanks in advance.
Here my code.
Option Explicit
Private Lrow As Long
Private oDict As Object
Private Sub CreateDict()
Dim arrValues As Variant, oKey As Variant, oValue As Variant, i As Long
'Find Master Item List Japan
Dim Master As Workbook
Dim t As Workbook
For Each t In Workbooks
If Left(t.Name, 16) = "Master Item List" Then
Set Master = Workbooks(t.Name)
End If
Next t
Set oDict = Nothing
If oDict Is Nothing Then
Set oDict = New Scripting.Dictionary
End If
' Add items to the dictionary
' Load values of used range to memory
arrValues = Master.Sheets("Sheet2").UsedRange.Value
' Assuming the Key is on first column and Value is on next
For i = 2 To UBound(arrValues)
oKey = arrValues(i, 3)
oValue = arrValues(i, 6)
If Len(oKey) > 0 Then
If oDict.Exists(oKey) Then
' Append Value to existing key
oDict(oKey) = oDict(oKey) + oValue
Else
' Add Key and value
oDict(oKey) = oValue
End If
End If
Next i
End Sub
Function GetList(ByVal oRange As Range) As Variant
If oDict Is Nothing Then CreateDict
' Static oDict As Scripting.Dictionary 'precerved between calls
If oDict.Exists(oRange.Value) Then
GetList = oDict.Item(oRange.Value)
' Else
' GetList = 0
End If
End Function
Just For Reference.
This is code I use in other workbook and working nicely
Option Explicit
Private lRow As Long
Private oDict As Object
Private Sub CreateDict()
Dim arrValues As Variant, oKey As Variant, oValue As Variant, i As Long
'Find Master Item List Japan
Dim Master As Workbook
Dim t As Workbook
For Each t In Workbooks
If Left(t.Name, 16) = "Master Item List" Then
Set Master = Workbooks(t.Name)
End If
Next t
Set oDict = Nothing
If oDict Is Nothing Then
Set oDict = New Scripting.Dictionary
End If
' Add items to the dictionary
' Load values of used range to memory
arrValues = Master.Sheets("Sheet2").UsedRange.Value
' Assuming the Key is on first column and Value is on next
For i = 1 To UBound(arrValues)
oKey = arrValues(i, 3)
oValue = arrValues(i, 6)
If Len(oKey) > 0 Then
If oDict.Exists(oKey) Then
' Append Value to existing key
oDict.Item(oKey) = oDict.Item(oKey)
Else
' Add Key and value
oDict.Add oKey, oValue
End If
End If
Next
End Sub
Function GetList(ByVal oRange As Range) As Long
If oDict Is Nothing Then CreateDict
' Static oDict As Scripting.Dictionary 'precerved between calls
If oDict.Exists(oRange.Value) Then
GetList = oDict.Item(oRange.Value)
Else
GetList = 0
End If
End Function
EDIT #1:
Based on #YowE3k comment I try execute the GetFile Function and got the result as picture below.
Not very sure why last one return with 0
Can this is because it have same key already in my dictionary history because in other workbook I use same key.

Highlighting word excel

I am writing a VBA program that will allow me to mine through a set of Excel data and pull out relevant information which is then copied to another sheet.
I keep trying to make it so that the word that is being searched for is highlighted in yellow, however my program constantly throws "Compile error - expected array on Ubound".
Option Compare Text
Public Sub Textchecker()
'
' Textchecker
'
' Keyboard Shortcut: Ctrl+h
'
Dim Continue As Long
Dim findWhat As String
Dim LastLine As Long
Dim toCopy As Boolean
Dim cell As Range
Dim item As Long
Dim j As Long
Dim sheetIndex As Long
Dim inclusion As String
sheetIndex = 2
Continue = vbYes
Do While Continue = vbYes
findWhat = CStr(InputBox("What word would you like to search for today?"))
inclusion = CStr(InputBox("Do you have any inclusions? Separate words with commas"))
LastLine = ActiveSheet.UsedRange.Rows.Count
If findWhat = "" Then Exit Sub
j = 1
For item = 1 To LastLine
If UBound(inclusion) >= 0 Then
For Each cell In Range("BY1").Offset(item - 1, 0) Then
For Each item In inclusion
If InStr(cell.Text, findWhat) <> 0 And InStr(cell.Text, inclusion) <> 0 Then
findWhat.Interior.Color = 6
toCopy = True
Else
For Each cell In Range("BY1").Offset(item - 1, 0) Then
If InStr(cell.Text, findWhat) <> 0 Then
findWhat.Interior.Color = 6
toCopy = True
End If
Next item
End If
Next
If toCopy = True Then
Sheets(sheetIndex).Name = UCase(findWhat) + "+" + LCase(inclusion)
Rows(item).Copy Destination:=Sheets(sheetIndex).Rows(j)
j = j + 1
End If
toCopy = False
Next item
sheetIndex = sheetIndex + 1
Continue = MsgBox(((j - 1) & " results were copied, do you have more keywords to enter?"), vbYesNo + vbQuestion)
Loop
End Sub
What am I doing wrong here?
In your code, inclusion is declared as a String variable, and contains a String, albeit a String separated by commas. The Ubound function works on arrays.
To fix: Convert the string into an array using the Split function. See the below example for some quick help, and let us know if you need more details.
Sub Tests()
Dim inclusion() As String
inclusion = Split("One, Two, Three", ",")
MsgBox (UBound(inclusion))
End Sub
To answer your last comment.
A variable in For Each must be of type Object or Variant.
To change your 'item' in a Variant, replace 'Dim item As Long' by 'Dim item As Variant', or even by 'Dim item' as a variable declared without a type is a Variant.

Read Cell properties in Visio using vb

I am trying to create a VB macro in Visio that can read the data and properties of the shape. So say I have a Rectangle Shpae in Visio with Cells Name, Description, Type, Size.... and so on.
When I try to read the cells and their values I am only getting the first cell and its value.
Here is my code . I would appreciate some help here.
Sub Testing()
Dim excelObj As Object
Dim excelFile As String
Dim sheetName As String
' Dim excelBook As Excel.Workbook
' Set excelFile = "C:\Users\hbhasin\Documents\test.xls"
'Set sheetName = "New Sheet name"
Set excelObj = CreateObject("Excel.Application")
excelObj.Workbooks.Add
Dim pagObj As Visio.Page
Dim shpsObj As Visio.shapes
Dim shapes As Visio.shapes
Dim shpObj As Visio.Shape
Dim CellObj As Visio.Cell
Dim Storage() As String
Dim iShapeCount As Integer
Dim i As Integer
Dim j As Integer
Set pagObj = ActivePage
Set shpsObj = pagObj.shapes
iShapeCount = shpsObj.Count
Debug.Print iShapeCount
ReDim Storage(8, iShapeCount - 1)
For i = 1 To iShapeCount - 1
Set shpObj = shpsObj(i)
Storage(1, i - 1) = shpObj.Name
If shpObj.CellExists("Prop.Name", visExistsLocally) Then
Set CellObj = shpObj.CellsU("Prop.Name")
Storage(2, i - 1) = CellObj.ResultStr("")
End If
If shpObj.CellExists("Prop.Description", visExistsLocally) Then
Debug.Print "Test the IF statement"
Set CellObj = shpObj.CellsU("Prop.Description")
Storage(3, i - 1) = CellObj.ResultStr("")
End If
Next
For i = 0 To iShapeCount - 1
Debug.Print "Name- " & Storage(0, i)
Debug.Print "Description-" & Storage(1, i)
Next
End Sub
In fact, I have put a debug statement within the second if clause and that does not execute which tells me the compiler is not even seeing the second cell or any cell after.
If you're not getting the Description Shape Data it maybe that it's not local, but inherited from its master. Here's a slight modification of your code (with the Excel part removed as I don't think it's relevant here):
Sub Testing()
Dim shpsObj As Visio.shapes
Set shpsObj = ActivePage.shapes
Dim iShapeCount As Integer
iShapeCount = shpsObj.Count
'Assumes you want an array of shape data
Dim Storage() As String
ReDim Storage(iShapeCount - 1, 2)
'Visio shapes are 1 based so use full count
Dim i As Integer
Dim shpObj As Visio.Shape
For i = 1 To iShapeCount
Set shpObj = shpsObj(i)
Storage(i - 1, 0) = shpObj.Name 'Do you want NameU?
'Assumes you don't care whether the cell is local or inherited
If shpObj.CellExistsU("Prop.Name", visExistsAnywhere) Then
Storage(i - 1, 1) = shpObj.CellsU("Prop.Name").ResultStr("")
End If
If shpObj.CellExistsU("Prop.Description", visExistsAnywhere) Then
Storage(i - 1, 2) = shpObj.CellsU("Prop.Description").ResultStr("")
End If
Next
Dim j As Long
For j = LBound(Storage, 1) To UBound(Storage, 1)
Debug.Print "Shape Name- " & Storage(j, 0)
Debug.Print " Prop.Name- " & Storage(j, 1)
Debug.Print " Prop.Description- " & Storage(j, 2)
Next j
End Sub
If you're just running through all the shapes on the page, then you might want to look at For Each shp In shapes as an alternative. Check out this page for more details:
http://visualsignals.typepad.co.uk/vislog/2007/11/looping-through.html
Also, you might want to try look at the CreateSelection page method to narrow down your target shapes if you're dealing with a large number

Using Range.Offset but "User-defined type not defined" popup in VBA

I write a simple function in the Modules as follow:
Function allocate(ByVal pq As PriceQtyClass, ByVal al As AllocationClass) As Boolean
Dim tmpRange As Range
Dim tmpDic As Dictionary
Dim rowIndex As Integer
Set tmpDic = pq.priQtyDic
Set tmpRange = Application.ActiveCell.Offset(0, 1)
rowIndex = 1
For Each k In tmpDic
set tmpRange = k 'adding set here isnot working
rowIndex = rowIndex + 1
Next
End Function
When it goes to tmpRange = k, Message with "User-defined type not defined" popup!
I don't know why it is and where is wrong!
Please help!