I'm trying to check some CheckBoxes programatically.
I read this post to do it.
How To Get Control Property by "String Name"?
My code:
1)
Dim FiltrosStr As String = AnswerX.Substring(7)
Dim Filt13() As String = FiltrosStr.Split(",")
If Filt13.Length >= 2 Then
Dim Filt1 = Filt13(0)
Dim Filt3 = Filt13(1)
x = 1
For Each XBit As Char In Filt1
Dim ChkName As String = "Filt" & x.ToString & "xxEvtVerChk"
Dim ChkX As CheckBox = Me.Controls.Find(ChkName, True).FirstOrDefault()'<-Halt here
If XBit = "1" Then
ChkX.Checked = True
Else
ChkX.Checked = False
End If
x += 1
If x > 6 Then
Exit For
End If
Next
2) Also tried
Dim x As Integer
Dim FiltrosStr As String = AnswerX.Substring(7)
Dim Filt13() As String = FiltrosStr.Split(",")
If Filt13.Length >= 2 Then
Dim Filt1 = Filt13(0)
Dim Filt3 = Filt13(1)
x = 1
For Each XBit As Char In Filt1
Dim ChkName As String = "Filt" & x.ToString & "xxEvtVerChk"
Dim ChkX As CheckBox = CType(Me.Controls(ChkName), CheckBox)'<-Halt here
If XBit = "1" Then
ChkX.Checked = True
Else
ChkX.Checked = False
End If
x += 1
If x > 6 Then
Exit For
End If
Next
I just need to check or uncheck some checkboxes that are inside a three level TabPage
Form-> TabPage-> TabPage-> TabPage-> GroupBox-> CheckBox
The 12 Check Boxes have almost the same name, only changes one number in the middle of it names.
I don't understand what I doing wrong and why even the IDE get halted.
The only way to stop it is by closing the session or restart Windows.
Related
Usually I can figure out a way to generalize my problem and Google it but I can't even begin to figure out what is happening.
As a disclaimer, I am not a professional programmer. I work in a finance department. I'm just playing around with VBA inside of Excel.
I am trying to learn collections and class modules in VBA and I've run into a really weird problem. So what I'm trying to do is make a program that runs a breadth first search to solve a ball sort puzzle.
So in my module, I run a sub that loads the starting board state into an array I call field(). So my current field looks like
Field ((a,f,d,e),(b,g,d,h),...,(x,x,x,x),(x,x,x,x))
Each letter is a string (this is so that I can alphabetized the board state to make sure I'm not repeating the same moves over and over again).
What I want is for when I create a class, it will store the current board, the solution up to that point, and the possible valid moves from that state. The way I achieve this is:
Sub solvepuzzle()
Call loadboard 'this handles creating the game board
Dim testboard as variant
Dim o as New Board
o.ordered = field()
testboard = o.moves
End sub
Board class:
Private tubes as new collection
Private tempx as integer
Private tempy as integer
Property let ordered(current as variant)
'This just loads the field into the object. When I step through this it works fine.
'But when I run it, it seems like it runs the moves property.
Dim rws as integer
Dim clms as integer
Dim i, j as integer
Dim focus() as variant
rws = Ubound(current,2)
clms = Ubound(current,1)
For j = 0 to clms
Redim focus(rws)
For i = 0 to rws
Focus(i) = current(j,i)
Next i
Tubes.add focus
Next j
End property
Property get moves() as collection
For starttube = 1 to clms
For endtube = 1 to clms
If isvalid(starttube, endtube, rws) then
'Once it has found a valid move it copys the array to an array I Dimmed
'in the move property, then it removes the array from its spot in the
'tubes collection. Then it saves the string letter of the chosen ball
'to a variable, and changes the position in the array to an "x" Since
'e that is my variable I use for an empty space.
'Then it replaces the array back where it was in the tubes collection.
'Then it repeats this but for the ending location. It removes the array,
'and replaces the last "x" with the moving string. And then it inserts it
'back into the tubes collection.
'I check to see if it is a board state I haven't been to yet in this
'solution path, then I create a copy of the board inside a different
'collection and then undo the move.
'this is as far as I've written.
End property
So when I step through the code ordered simply places the field() array into a tubes collection inside the object. Everything works. However when I run the code, if I set a breakpoint just after it loads the field() into tubes, but before I've even left the property, if I check the locals window, tubes now has moved the first string to the location it is first allowed to move to. So it should be tubes(1) = (a,f,d,e) and tubes(10) = (x,x,x,x) however after I run the code it shows tubes(1) = (x,f,d,e) and tubes(10) = (x,x,x,a).
I thought maybe that since it is a class that VBA is trying to prepare the other properties when called for but it shouldn't be keeping that change because in the move property I'm undoing the move. So it should stay the same.
So the problem is that when I step through the code it works perfectly, exactly like I want it to. However when I let it run by the time it hits my breakpoints it has screwed it up and starts doing other moves that I haven't investigated yet.
Thank you for any help. I tried to put in as much of the code as I could. Although I just saw below that it did not format properly but I'm not entirely sure how to fix that. I'll answer any questions I can. I'm just completely stumped.
Here is a code that reproduces the problem.
Sub test()
Dim i, j As Integer
Dim field() As Variant
Dim rws As Integer
Dim clms As Integer
Dim o As New Board
rws = 3
clms = 10
ReDim field(clms, rws)
For i = 0 To clms
For j = 0 To rws
field(i, j) = Range("B2").Offset(j, i).Value
Next j
Next i
o.ordered = field
End Sub
' Board Class
Private tubes As New Collection
Private alphaorder As String
Private sol As New Collection
Private paststates As New Collection
Private tempx As Integer
Private tempy As Integer
Property Get name() As String
name = alphaorder
End Property
Property Get moves() As Collection
Dim rws As Integer
Dim clms As Integer
Dim x, y As Integer
Dim starttube As Integer
Dim endtube As Integer
Dim possible As New Collection
Dim stringcheck As String
Dim tuberemove As Variant
Dim ballcolor As String
rws = UBound(tubes(1), 1)
clms = tubes.count
For starttube = 1 To clms
For endtube = 1 To clms
If isvalid(starttube, endtube, rws) Then
tuberemove = tubes(starttube)
tubes.Remove starttube
ballcolor = tuberemove(tempx)
tuberemove(tempx) = "x"
tubes.Add tuberemove, , starttube
tuberemove = tubes(endtube)
tubes.Remove endtube
tuberemove(tempy) = ballcolor
tubes.Add tuberemove, , endtube
stringcheck = alphabetize(rws, clms - 1)
For Each x In paststates
If x = stringcheck Then
GoTo failskip
End If
Next
possible.Add stringcheck
possible.Add starttube
possible.Add tempx
possible.Add endtube
possible.Add tempy
For Each x In tubes
possible.Add x
Next
moves.Add possible
Set possible = Nothing
failskip:
tuberemove = tubes(endtube)
tubes.Remove endtube
ballcolor = tuberemove(tempy)
tuberemove(tempy) = "x"
tubes.Add tuberemove, , endtube
tuberemove = tubes(starttube)
tubes.Remove starttube
tuberemove(tempx) = ballcolor
tubes.Add tuberemove, , starttube
End If
Next endtube
Next starttube
End Property
Private Function isvalid(starttube As Integer, endtube As Integer, rws As Integer) As Boolean
Dim ballcolor As String
If starttube = endtube Then
isvalid = False
Exit Function
End If
If tubes(starttube)(rws) = "x" Or tubes(endtube)(0) <> "x" Then
isvalid = False
Exit Function
End If
For tempx = 0 To rws
If tubes(starttube)(tempx) <> "x" Then
ballcolor = tubes(starttube)(tempx)
Exit For
End If
Next tempx
For tempy = 0 To rws - 1
If tubes(endtube)(tempy + 1) <> "x" Then
If tubes(endtube)(tempy + 1) <> ballcolor Then
isvalid = False
Exit Function
Else
Exit For
End If
End If
Next tempy
isvalid = True
End Function
Property Let ordered(current As Variant)
Dim rws As Integer
Dim clms As Integer
Dim x, y As Integer
Dim focus() As Variant
rws = UBound(current, 2)
clms = UBound(current, 1)
For y = 0 To clms
ReDim focus(rws)
For x = 0 To rws
focus(x) = current(y, x)
Next x
tubes.Add focus
Next y
alphaorder = alphabetize(rws, clms)
paststates.Add alphaorder
End Property
Private Function alphabetize(rws As Integer, clms As Integer) As String
Dim alphax
Dim order() As Variant
Dim hold() As Variant
Dim newhold() As Variant
Dim count As Integer
Dim level As Integer
Dim done1, done2 As Boolean
Dim x, y As Integer
Dim symbolhold As Integer
ReDim alphax(16)
alphax = Array("x", "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p")
ReDim order(clms)
ReDim hold(rws)
ReDim newhold(rws)
For y = 0 To clms
order(y) = y
Next y
done1 = False
For y = 1 To clms
For count = 0 To clms - y
level = 0
nextsize:
done2 = False
For x = 0 To UBound(alphax, 1)
If done1 = False Then
If tubes(order(count) + 1)(level) = alphax(x) Then
hold(level) = x
done1 = True
End If
End If
If done2 = False Then
If tubes(order(count + 1) + 1)(level) = alphax(x) Then
newhold(level) = x
done2 = True
End If
End If
If done1 And done2 Then
Exit For
End If
Next x
Select Case hold(level)
Case Is < newhold(level)
For x = 0 To level
hold(x) = newhold(x)
Next x
Case Is > newhold(level)
symbolhold = order(count + 1)
order(count + 1) = order(count)
order(count) = symbolhold
Case Is = newhold(level)
If level < rws Then
level = level + 1
done1 = False
GoTo nextsize
End If
End Select
Next count
done1 = False
Next y
For y = 0 To clms
For x = 0 To rws
alphabetize = alphabetize + tubes(order(y) + 1)(x)
Next x
Next y
End Function
Starting in range B2 I have various letters representing the color of the ball there. x is used to denote an empty space so the last 2 columns are just x.
If you go put a breakpoint at the alphaorder part in the ordered property and check the tubes(1) it shows an x in the first position and tubes(10) has an a in the last position which isn't supposed to happen until during the moves property which has not been called yet. On top of that the moves property is supposed to undo the change.
Again thank you for any help.
I have a code where I'm adding last rows to collection which should be later transformed to an array and final step is to get last row with the least number of cells in it.
My current code is:
Dim lastc, lastc2, lastr, FindColNumber, FindColNumber2 as Long
Dim FindCol as Range
Dim col As New Collection
Dim CollectionToArray As Variant
Set FindCol = 1 'example
FindColNumber = FindCol.Column
lastc = FindColNumber + 1
Set FindCol2 = 5 'example
FindColNumber = FindCol2.Column
lastc2 = FindColNumber - 1
For R = lastc2 To lastc Step -1
lastc2 = R
col.Add Cells(ws.Rows.count, R).End(xlUp).Row
Next R
Debug.Print WorksheetFunction.Min(CollectionToArray(col))
Public Function CollectionToArray(myCol As Collection) As Variant
Dim result As Variant
Dim cnt As Long
ReDim result(myCol.count - 1)
For cnt = 0 To myCol.count - 1
result(cnt) = myCol(cnt + 1)
Next cnt
CollectionToArray = result
End Function
I am still getting Type Mismatch error and when hovering over CollectionToArray(Col)) I see "Object variable or With block variable not set".
Thank you.
I want to run the fetching of a Database into a background worker but it seems to be crashing without Visual Studio returning me an error in my code.
Here's the code in the DoWork:
Private Sub ITSM_Fetch_BW_DoWork(sender As Object, e As System.ComponentModel.DoWorkEventArgs) Handles ITSM_Fetch_BW.DoWork
Dim sql As String = "xxxx"
Dim ConnString As String = "DRIVER={AR System ODBC Driver};ARServer=xxxx;ARServerPort=xxxx;ARPrivateRpcSocket=xxxx;UID=xxxx;PWD=xxxx;ARAuthentication=;ARUseUnderscores=1;SERVER=NotTheServer"
Dim connection As New Odbc.OdbcConnection(ConnString)
connection.Open()
Dim ODBC_Command As New Odbc.OdbcCommand(sql, connection)
Dim ODBC_reader As Odbc.OdbcDataReader
'Load the Data into the local Memory
ODBC_reader = ODBC_Command.ExecuteReader
e.Result = ODBC_reader
ODBC_reader.Close()
End Sub
Private Sub ITSM_Fetch_BW_RunWorkerCompleted(sender As Object, e As RunWorkerCompletedEventArgs) Handles ITSM_Fetch_BW.RunWorkerCompleted
Data = New DataTable
Data.Load(e.Result)
Dim Count_ToDo(5) As String
Count_ToDo(0) = "Product_Name"
Count_ToDo(1) = "Status"
Count_ToDo(2) = "Language"
Count_ToDo(3) = "Assigned_Group"
Count_ToDo(4) = "Priority"
Count_ToDo(5) = "Company"
For Each Item As String In Count_ToDo
Dim i As Integer = 0
Dim ITEM_Count(0, 1) As String
For Each Ticket As DataRow In Data.Rows
'PART FOR THE CI
If IsDBNull(Ticket.Item(Item)) = False Then
Dim IsInIndex As Integer = -1
If i = 0 Then
ITEM_Count(0, 0) = Ticket.Item(Item)
ITEM_Count(0, 1) = 1
Else
For x As Integer = 0 To ITEM_Count.GetLength(0) - 1
If ITEM_Count(x, 0) = Ticket.Item(Item) Then
IsInIndex = x
End If
Next
If IsInIndex = -1 Then
Dim ITEM_Count_Temp(ITEM_Count.GetLength(0), ITEM_Count.GetLength(0)) As String
ITEM_Count_Temp = ITEM_Count
ReDim ITEM_Count(ITEM_Count.GetLength(0), 1)
For x As Integer = 0 To ITEM_Count_Temp.GetLength(0) - 1
For y As Integer = 0 To ITEM_Count_Temp.GetLength(1) - 1
ITEM_Count(x, y) = ITEM_Count_Temp(x, y)
Next
Next
ITEM_Count(ITEM_Count.GetLength(0) - 1, 0) = Ticket.Item(Item)
ITEM_Count(ITEM_Count.GetLength(0) - 1, 1) = 1
Else
ITEM_Count(IsInIndex, 1) = ITEM_Count(IsInIndex, 1) + 1
End If
End If
Else
'IF NULL
End If
i = i + 1
Next
'CI_COUNT FILLING
'ORDERING BY COUNT
Dim ITEM_obj = New List(Of obj)
Dim ITEM_ToObj As String = ""
Dim ITEMCount_ToObj As String = ""
For x As Integer = 0 To ITEM_Count.GetLength(0) - 1
ITEM_ToObj = ITEM_Count(x, 0)
ITEMCount_ToObj = ITEM_Count(x, 1)
ITEM_obj.Add(New obj(ITEM_ToObj, ITEMCount_ToObj))
Next
ITEM_obj = OrderItem(ITEM_obj)
Dim Item_Count_listview As ListViewItem
For Each Itemobj As obj In ITEM_obj
Dim Transfer_Array(2) As String
Transfer_Array(0) = Itemobj.Item
Transfer_Array(1) = Itemobj.Item_Count
Item_Count_listview = New ListViewItem(Transfer_Array)
Select Case Item
Case "Product_Name"
CI_Count_Table.Items.Add(Item_Count_listview)
Case "Status"
Status_Count_Table.Items.Add(Item_Count_listview)
Case "Language"
Language_Count_Table.Items.Add(Item_Count_listview)
Case "Assigned_Group"
AssignedGroup_Count_Table.Items.Add(Item_Count_listview)
Case "Priority"
Priority_Count_Table.Items.Add(Item_Count_listview)
Case "Company"
LOB_Count_Table.Items.Add(Item_Count_listview)
Case Else
MsgBox("No Category Of this type exist. Programming Issue. Item is: " & Item)
End Select
Next
Next
End Sub
What is not possible to run into a background worker like this?
regards,
I have two forms:
Editor
Tables
On the "Editor" form I have a "KeyDown" event which opens the "Tables" form when the F5 key is down.
Private Sub DataGridView_KeyDown(ByVal sender As Object, ByVal e As System.Windows.Forms.KeyEventArgs) Handles DataGridView.KeyDown
Select Case e.KeyCode
Case Keys.Delete
For Each Row As DataGridViewRow In DataGridView.Rows
If Row.IsNewRow Then
DataGridView.Rows.Remove(Row)
End If
Next
Case Keys.F5
Tabels.Show()
End Select
End Sub
On the "Tables" form I have some code which get's a List(Of String) and loops through it, adding rows to a datagridview on the form.
Dim Tables As List(Of String)
Tables = NAV2013BLOBReader.ReturnXML("SELECT [Metadata] FROM dbo.[Object Metadata] WHERE [Object Type] = 1")
'Sæt egenskaber på datagridview
DataGridView.AutoGenerateColumns = False
Dim Row As DataGridViewRow = DataGridView.Rows(0).Clone()
For Each Line As String In Tables
If Line.Contains("MetaTable") Then
Dim LanguageStartIndex As Integer = Line.IndexOf("CaptionML=""") + 15
Dim LanguageEndIndex As Integer = Line.IndexOf(";", LanguageStartIndex)
Dim IdStartIndex As Integer = Line.IndexOf("ID=""") + 4
Dim IdEndIndex As Integer = Line.IndexOf(""" CaptionML") - IdStartIndex
Dim NameStartIndex As Integer = Line.IndexOf("Name=""") + 6
Dim NameEndIndex As Integer = Line.IndexOf(""" LookupFormID") - NameStartIndex
'Tildel cellerne værdier
Row.Cells(0).Value = Line.Substring(IdStartIndex, IdEndIndex)
Row.Cells(1).Value = Line.Substring(NameStartIndex, NameEndIndex)
Row.Cells(2).Value = Line.Substring(LanguageStartIndex, LanguageEndIndex - LanguageStartIndex)
DataGridView.Rows.Add(Row)
DataGridView.Refresh()
End If
Next
DataGridView.AllowUserToAddRows = False
The problem is that when the loop has iterated twice, the flow will exit the loop and go back to the KeyDown event, which then finishes.
If I empty out the code in the If Line.Contains statement, and insert a MessageBox, everything iterates just fine.
I hope someone knows the answer.
Thanks and best regards!
EDIT: I can see that DataGridView.Rows.Add(Row) is at fault, I have no idea why though.
EDIT: I fixed it by changing the "For Each" loop to a "For" loop, and cloning the latest added row.
For i = 0 To Tables.Count - 1
Dim Row As DataGridViewRow = DataGridView.Rows(i).Clone()
If Tables(i).Contains("MetaTable") Then
Dim LanguageStartIndex As Integer = Tables(i).IndexOf("CaptionML=""") + 15
Dim LanguageEndIndex As Integer = Tables(i).IndexOf(";", LanguageStartIndex)
Dim IdStartIndex As Integer = Tables(i).IndexOf("ID=""") + 4
Dim IdEndIndex As Integer = Tables(i).IndexOf(""" CaptionML") - IdStartIndex
Dim NameStartIndex As Integer = Tables(i).IndexOf("Name=""") + 6
Dim NameEndIndex As Integer = Tables(i).IndexOf("""", Tables(i).IndexOf("Name=""") + 6) - NameStartIndex
'Tildel cellerne værdier
Row.Cells(0).Value = Tables(i).Substring(IdStartIndex, IdEndIndex)
Row.Cells(1).Value = Tables(i).Substring(NameStartIndex, NameEndIndex)
Row.Cells(2).Value = Tables(i).Substring(LanguageStartIndex, LanguageEndIndex - LanguageStartIndex)
'Tilføj række til DataGridView og opfrisk kontrollen, så at de nye rækker bliver vist med det samme
DataGridView.Rows.Add(Row)
DataGridView.Refresh()
End If
Next
EDIT: I fixed it by changing the "For Each" loop to a "For" loop, and cloning the latest added row.
For i = 0 To Tables.Count - 1
Dim Row As DataGridViewRow = DataGridView.Rows(i).Clone()
If Tables(i).Contains("MetaTable") Then
Dim LanguageStartIndex As Integer = Tables(i).IndexOf("CaptionML=""") + 15
Dim LanguageEndIndex As Integer = Tables(i).IndexOf(";", LanguageStartIndex)
Dim IdStartIndex As Integer = Tables(i).IndexOf("ID=""") + 4
Dim IdEndIndex As Integer = Tables(i).IndexOf(""" CaptionML") - IdStartIndex
Dim NameStartIndex As Integer = Tables(i).IndexOf("Name=""") + 6
Dim NameEndIndex As Integer = Tables(i).IndexOf("""", Tables(i).IndexOf("Name=""") + 6) - NameStartIndex
'Tildel cellerne værdier
Row.Cells(0).Value = Tables(i).Substring(IdStartIndex, IdEndIndex)
Row.Cells(1).Value = Tables(i).Substring(NameStartIndex, NameEndIndex)
Row.Cells(2).Value = Tables(i).Substring(LanguageStartIndex, LanguageEndIndex - LanguageStartIndex)
'Tilføj række til DataGridView og opfrisk kontrollen, så at de nye rækker bliver vist med det samme
DataGridView.Rows.Add(Row)
DataGridView.Refresh()
End If
Next
I'm trying to write a program that will loop through cells of a specific column (assigned by the user), find new values in those cells and count how many times a specific value is found. The main problem I'm having right now is that this is hard-coded like below:
Function findValues() As Long
For iRow = 2 To g_totalRow
If (ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text = "") Then
nullInt = nullInt + 1
ElseIf (someValue1 = "" Or someValue1 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue1 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt1 = someInt1 + 1
ElseIf (someValue2 = "" Or someValue2 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue2 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt2 = someInt2 + 1
ElseIf (someValue3 = "" Or someValue3 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue3 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt3 = someInt3 + 1
ElseIf (someValue4 = "" Or someValue4 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue4 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt4 = someInt4 + 1
ElseIf (someValue5 = "" Or someValue5 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue5 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt5 = someInt5 + 1
ElseIf (someValue6 = "" Or someValue6 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue6 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt6 = someInt6 + 1
ElseIf (someValue7 = "" Or someValue7 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue7 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt7 = someInt7 + 1
ElseIf (someValue8 = "" Or someValue8 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue8 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt8 = someInt8 + 1
ElseIf (someValue9 = "" Or someValue9 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue9 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt9 = someInt9 + 1
ElseIf (someValue10 = "" Or someValue10 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text) Then
someValue10 = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
someInt10 = someInt10 + 1
End If
Next iRow
End Function
Here, if the ActiveCell is blank then the nullInt will get incremented, if the ActiveCell has some value then it'll find which of the variables has that same value or the ActiveCell value will be assigned to one of the variables. I created ten variables strictly for testing purposes but I need to make up to one hundred. I was wondering if there was a way to complete this quickly. The only way I could think of was to create a String array and an Int array and store the values that way. However I'm not sure if this is the best way to get this done.
Edit
This portion is directed specifically to dictionaries. Say there is a specific column titled "State". This contains the 50 North American states. Some of these states are repeated and there is a total of 800 values in this column. How do I keep track of how many times (for example) Texas gets hit?
Thank you,
Jesse Smothermon
You should be able to do this with a Dictionary (see Does VBA have Dictionary Structure?)
This code hasn't been tested but should give you a start.
Function findValues() As Scripting.Dictionary
Dim cellValue
Dim dict As New Scripting.Dictionary
For iRow = 2 To g_totalRow
cellValue = ActiveWorkbook.Sheets(sheetName).Cells(iRow, iCol).Text
If dict.Exists(cellValue) Then
dict.Item(cellValue) = dict.Item(cellValue) + 1
Else
dict.Item(cellValue) = 1
End If
Next iRow
Set findValues = dict
End Function
Sub displayValues(dict As Scripting.Dictionary)
Dim i
Dim value
Dim valueCount
For i = 1 To dict.count
valueCount = dict.Items(i)
value = dict.Keys(i)
ActiveWorkbook.Sheets(sheetName).Cells(i, 3).Text = value
ActiveWorkbook.Sheets(sheetName).Cells(i, 4).Text = valueCount
Next i
End Sub
Sub RunAndDisplay()
Dim dict
Set dict = findValues
displayValues dict
End Sub
I've drafted a code for you, hope it helps. I added comments to make each step clearer for you. I believe that simply setting the proper values in the 1st step might make it work for you.
Still, would worth to understand what the code does to help you in the future.
Hope it fits your needs!
Option Explicit
Sub compareValues()
Dim oSource As Excel.Range
Dim oColumn As Excel.Range
Dim oCell As Excel.Range
Dim sBookName As String
Dim sSheetCompare As String
Dim sSheetSource As String
Dim sUserCol As String
Dim sOutputCol As String
Dim sFirstCell As String
Dim vDicItem As Variant
Dim sKey As String
Dim iCount As Integer
Dim sOutput As String
Dim oDic As Scripting.Dictionary
'1st - Define your source for somevalues and for the data to be compared
sBookName = "Book1"
sSheetCompare = "Sheet1"
sSheetSource = "Sheet2"
sFirstCell = "A1"
sOutputCol = "C"
'2nd - Define the 'somevalues' origin value; other values will be taken
' from the rows below the original value (i.e., we'll take our
' somevalues starting from sSheetSource.sFirstCell and moving to the
' next row until the next row is empty
Set oSource = Workbooks(sBookName).Sheets(sSheetSource).Range(sFirstCell)
'3rd - Populate our dictionary with the values beggining in the sFirstCell
populateDic oSource, oDic
'At this stage, we have all somevalues in our dictionary; to check if the
' valuesare as expected, uncomment the code below, that will print into
' immediate window (ctrl+G) the values in the dictionary
For Each vDicItem In oDic
Debug.Print vDicItem
Next vDicItem
'4th - ask the user for the column he wants to use; Use single letters.
' E.g.: A
sUserCol = InputBox("Enter the column the data will be compared")
'5th - scan the column given by the user for the values in the dictionary
Set oColumn = Workbooks(sBookName).Sheets(sSheetCompare).Columns(sUserCol)
'6th - Now, we scan every cell in the column
For Each oCell In oColumn.Cells
sKey = oCell.Value
'7th - Test the special case when the cell is empty
If sKey = "" Then oDic("Empty") = oDic("Empty") + 1
'8th - Test if the key value exists in the dictionary; if so, add it
If oDic.Exists(sKey) Then oDic(sKey) = oDic(sKey) + 1
'9th - Added to exit the for when row reaches 1000.
If oCell.Row = 1000 Then Exit For
Next oCell
'10th - Now, we print back the counters we found, only for sample purposes
' From now on, is up to you how to use the dictionary :)
iCount = 1
Set oColumn = Workbooks(sBookName).Sheets(sSheetCompare).Columns(sOutputCol)
Set oCell = oColumn.Cells(1, 1)
For Each vDicItem In oDic
If oDic(vDicItem) > 0 Then
oCell.Value = vDicItem
oCell.Offset(0, 1).Value = oDic(vDicItem)
Set oCell = oCell.Offset(1, 0)
End If
Next vDicItem
End Sub
Sub populateDic(ByRef oSource As Excel.Range, _
ByRef oDic As Scripting.Dictionary)
'Ideally we'd test if it's created. Let's just set it for code simplicity
Set oDic = New Scripting.Dictionary
'Let's add an 'empty' counter for the empty cells
oDic.Add "Empty", 0
While Len(oSource.Value) > 0
'If the data is not added into somevalues dictionary of values, we add
If Not oDic.Exists(oSource.Value) Then oDic.Add CStr(oSource.Value), 0
'Move our cell to the next row
Set oSource = oSource.Offset(1, 0)
Wend
End Sub