I am trying to remove items from the dictionary which are already selected from the comboboxes. I have a following code but i dont know what the problem is.It gives me an object required error at d2("v" & cbnr).Remove (ss).
a is an Array.
Sub cb_pop2(cbnr As Integer)
Dim i, j As Integer
Dim d2 as object
Dim ss as string
Set d2 = CreateObject("Scripting.Dictionary")
d2("v" & cbnr) = a
For i = cbnr To 5
UserForm1.Controls("ComboBox" & i).Clear
For j = cbnr To i
ss = UserForm1.Controls("ComboBox" & j - 1).Value
d2("v" & cbnr).Remove (ss)
Next j
UserForm1.Controls("ComboBox" & i).List = d2("v" & cbnr).keys
UserForm1.Controls("ComboBox" & i).ListIndex = 0
Next i
End Sub
This is an example of using dictionary in VBA
Sub TestDictionary()
Set dict = CreateObject("Scripting.Dictionary")
For x = 1 To 5
Key = "Start" & x
Value = 0 + x
If Not dict.Exists(Key) Then
dict.Add Key, Value
End If
Next x
For Each k In dict.keys
MsgBox (dict(k))
Next
If dict.Exists(Key) Then
dict.Remove Key
Else
'You can put here a code to show errors
End If
End Sub
I suggest you to use an If-Then to check "Key" before adding/removing so you will able to intercept errors depending by "wrong Key" or "not present Key"
Related
I am working with Bloomberg's API in VBA and I want to be able to take in the arrays that the API gives out from requesting historical data and put it into a table that has field names. However, the array that the API gives me is given in this format: (x,y)(Z) but I cannot use that for inserting into a table. I also want to be able to add another piece of data into the array while I convert from one form to another
I have tried just going through the Bloomberg array and replacing each element in a different array, but the main issues I have are not being able to know how big I need the array to be and how I am going to loop through the bloomberg API without going out of index and getting an error. I have tried using Ubound, but it does not work the way I have intended.
This is the code I have tried using to convert my array and then insert it. It just puts in blank values and does not put in anything into the table
Sub mWriteToTable(vTableName As String, ByVal vArray As Variant, vCUSIPS As Variant, vFields As Variant)
On Error GoTo ErrorHandler
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim x As Long, y As Long
Dim TEST As String
Dim DataArray() As Variant
Set db = CurrentDb
Set rs = db.OpenRecordset(vTableName, dbOpenDynaset, dbSeeChanges)
TEST = ""
Dim xBound As Integer, yBound As Integer, ThirdBound As Integer, fieldcount As Integer, NewBoundY As Integer, Z As Integer
Dim Boundarynum As Integer
Boundarynum = 0
Dim Boundarynum1 As Integer
Boundarynum1 = 0
fieldcount = UBound(vFields, 1) + 1
xBound = UBound(vArray, 1)
yBound = UBound(vArray, 2)
NewBoundY = fieldcount * (fieldcount + 1)
ReDim DataArray(0 To 20, 0 To (xBound + 1))
'using a static size for the array for now. Will try and make it the same size as the bloomberg array
'TRANSFORMING ARRAY FROM BLOOMBERG
For x = 0 To xBound
For y = 0 To NewBoundY
For Boundarynum1 = 0 To yBound
On Error Resume Next
DataArray(Boundarynum, Boundarynum1) = vArray(x, y)(Boundarynum1)
Next
Boundarynum = Boundarynum + 1
Next
Next
'TRANSFORMING ARRAY FROM BLOOMBERG
'set CUSIP in array
y = 0
Dim counter As Integer
counter = 0
For Z = 0 To 20
If DataArray(Z, 0) = "" Then
Debug.Print ("")
counter = 1
ElseIf counter = 1 And DataArray(Z, 0) <> "" Then
y = y + 1
DataArray(Z, 3) = vCUSIPS(y)
counter = 0
Else
DataArray(Z, 3) = vCUSIPS(y)
End If
Next
'set CUSIP in array
For x = 0 To 20
With rs
.AddNew
For y = 0 To yBound
' On Error GoTo Line1
' If vArray(x, y) = "NA" Then
' TEST = "This is a test"
' End If
'Line1:
.fields(y) = DataArray(x, y)
Next
.Update
End With
Next
'Call fImmediateWindow(vArray)
ErrorHandler:
If Err.Number <> 0 Then
Dim vMsg As String
vMsg = "Error # " & Str(Err.Number) & " was generated by " & Err.Source & Chr(13) & "Error Line: " & Erl & Chr(13) & Err.Description
MsgBox vMsg, , "Error", Err.HelpFile, Err.HelpContext
End If
rs.Close
Set rs = Nothing
db.Close
Set db = Nothing
End Sub
'''
This is the way the Bloomberg Array looks when I get it. I am unsure of how to really work around this. The array from the program above just becomes blank.
Each element of the Bloomberg array is returning 2 sets of data. The key is to have your array have double the number of elements of the top level Bloomberg array.
Sub ConvertBloombergTestData()
Dim r As Variant
r = getBloombergTestData
Dim Values As Variant
Dim n As Long
Dim j As Long
Dim Item
ReDim Values(1 To (UBound(r) + 1) * 2, 1 To 2)
For n = LBound(r) To UBound(r)
j = j + 1
Item = r(n, 0)
Values(j, 1) = Item(0)
Values(j, 2) = Item(1)
Item = r(n, 1)
j = j + 1
Values(j, 1) = Item(0)
Values(j, 2) = Item(1)
Next
End Sub
Not knowing the the array nesting but knowing that we are returning pairs of data, we could add all the data to a collection and create our array bu iterating over the collection.
Sub Test()
Dim r As Variant, Values As Variant
r = getBloombergTestData
Values = ConvertBloombergArrayTo2d(r)
End Sub
Function ConvertBloombergArrayTo2d(BloombergArray)
Dim Map As New Collection
FlattenArray Map, BloombergArray
Dim Results As Variant
ReDim Results(1 To Map.Count / 2, 1 To 2)
Dim n As Long, j As Long
For n = 1 To Map.Count Step 2
j = j + 1
Results(j, 1) = Map.Item(n)
Results(j, 2) = Map.Item(n + 1)
Next
ConvertBloombergArrayTo2d = Results
End Function
Sub FlattenArray(Map As Collection, Element As Variant)
If Right(TypeName(Element), 2) = "()" Then
Dim Item
For Each Item In Element
FlattenArray Map, Item
Next
Else
Map.Add Element
End If
End Sub
I've implemented this macro whereby if i run it, it will show me the column and row of the word "needle" in the range A1:Z20. Although if there are multiple words of "needle" it will only output the last. How can I change this code to show me the first occurrence of the word?
Hope this makes sense, and here is my code so far:
Sub NeedleSearch()
Dim SearchSpace As Variant
Dim found As Boolean
found = False
SearchSpace = Range("A1:z20").Value
Dim i As Integer, j As Integer
For i = 1 To 20
For j = 1 To 26
If SearchSpace(i, j) = "needle" Then
Range("A25").Value = "Column " & j
Range("B25").Value = "Row " & i
found = True
End If
Next j
Next i
If found = False Then
Range("A25").Value = "needle not found"
Range("B25").Value = " "
End If
End Sub
With No Repeated Words
With 1 Repeated Word
If you need only first occurense just quit your loops!
Sub NeedleSearch()
Dim SearchSpace As Variant
Dim found As Boolean
found = False
SearchSpace = Range("A1:z20").Value
Dim i As Integer, j As Integer
For i = 1 To 20
For j = 1 To 26
If SearchSpace(i, j) = "needle" Then
Range("A25").Value = "Column " & j
Range("B25").Value = "Row " & i
found = True
End If
If found Then _
Exit For
Next j
If found Then _
Exit For
Next i
If found = False Then
Range("A25").Value = "needle not found"
Range("B25").Value = " "
End If
End Sub
To elaborate further: What this code actually does, if there are multiple instances of needle is, it will print all instances of found cells into A25:B25. Let's say there are 3 instances of needle e.g. in A1, B2 and C3. Your loop prints A1 into A25:B25 first, then B2 and then C3. Because it is happening so fast, you only see C3 or what you called the "last occurence".
What you can do to print out all solutions (which is what I'm guessing you're trying to do in the end) you could change your code to something like this:
Sub NeedleSearch()
Dim SearchSpace As Variant
Dim found As Boolean
found = False
SearchSpace = Range("A1:z20").Value
Dim ws As Worksheet
Dim i As Integer
Dim j As Integer
Dim k As Integer
Set ws = ThisWorkbook.Sheets(1)
k = 25
For i = 1 To 20
For j = 1 To 26
If SearchSpace(i, j) = "needle" Then
ws.Cells(k, 1).Value = "Occurence " & k - 24
ws.Cells(k, 2).Value = "Column " & j
ws.Cells(k, 3).Value = "Row " & i
k = k + 1
found = True
End If
Next j
Next i
If found = False Then
ws.Range("A25").Value = "needle not found"
End If
End Sub
Change your Sheet ID accordingly.
HTH
you can avoid loops by means of Find() method of Range object:
Option Explicit
Sub NeedleSearch()
Dim f As Range
Set f = Range("A1:Z20").Find(what:="needle", LookIn:=xlValues, lookat:=xlWhole, After:=Range("Z20"), SearchOrder:=xlByRows)
If f Is Nothing Then
Range("A25").Value = "needle not found"
Range("B25").Value = " "
Else
Range("A25").Value = "Column " & f.Column
Range("B25").Value = "Row " & f.Row
End If
End Sub
that can also be rewritten as follows:
Sub NeedleSearch()
Dim f As Range
Dim arr As Variant
Set f = Range("A1:Z20").Find(what:="needle", LookIn:=xlValues, lookat:=xlWhole, After:=Range("Z20"), SearchOrder:=xlByRows)
If f Is Nothing Then
arr = Array("needle not found", " ")
Else
arr = Array("Column " & f.Column, "Row " & f.Row)
End If
Range("A25:B25").Value = arr
End Sub
I have an application for which I am currently using a dictionary object (specifically, it's a dictionary of dictionaries of dictionaries, so each lookup has three steps, if that makes any sense!). I do a large number of lookups on these dictionaries and multiply the results together.
The problem is that in the previous version of the application, I used the VLookup function to accomplish this functionality, and it would error out when I would try to look up a key that didn't exist. Now, it returns a "Empty", which Excel is happy to multiply by whatever I already had and return a zero. This is hard to track, and I'd very much prefer for it to return an error like before.
Is there something I can change to get it to return the error like it would with a VLookup, or do I need to create a new class module to do this? A class module would likely require me to re-write a large amount of code, which I'd like to avoid (there are hundreds of lookups I would have to update in the code).
Thanks.
Here is some of my code:
This is the module I use to load in all the tables to the dictionary:
Sub LoadFactorsAndBaseRates()
Dim t As Double
t = Timer
Dim n As Name
Dim TempArray()
Dim dict1 As Dictionary
Dim dict2 As Dictionary
Dim i As Integer
Dim j As Integer
For Each n In ThisWorkbook.Names
If InStr(1, n.RefersTo, "#") <> 0 Or InStr(1, n.RefersTo, "\") Then GoTo skipname
If Not FactorLookup.Exists(n.Name) And n.RefersToRange.Parent.Name <> "Rate Matrix" And InStr(1, n.Name, "Print") = 0 And InStr(1, n.Name, "FilterDatabase") = 0 And n.Name <> "Policies" Then
Set dict1 = New Dictionary
On Error GoTo err1
TempArray = n.RefersToRange.Value
For j = 1 To n.RefersToRange.Columns.Count
On Error Resume Next
Set dict2 = New Dictionary
For i = 1 To UBound(TempArray, 1)
dict2.Add TempArray(i, 1), TempArray(i, j)
Next i
dict1.Add j, dict2
Next j
Erase TempArray
FactorLookup.Add n.Name, dict1
End If
skipname:
Next n
Exit Sub
err1:
If Err.number = 1004 Then Resume skipname
End Sub
And here is a sample of the lookup code:
CoverageColumn = 2
'Base Rate
Temp = FactorLookup("Base_Rates")(CoverageColumn)(State & "_" & Company & "_" & Terr)
If Vehicle <> "Snowmobile" Then
'Class 1
x = FactorLookup("Class1")(CoverageColumn)(State & "_" & Company & "_" & Class1)
Temp = xRound(Temp * x, 1)
'Class 2
x = FactorLookup("Class2")(CoverageColumn)(State & "_" & Company & "_" & Class2)
Temp = xRound(Temp * x, 1)
'Class 3
x = FactorLookup("Class3")(CoverageColumn)(State & "_" & Company & "_" & Class3)
Temp = xRound(Temp * x, 1)
'Class 4
x = FactorLookup("Class4")(CoverageColumn)(State & "_" & Company & "_" & Class4)
Temp = xRound(Temp * x, 1)
The code is basically just a bunch of pages of this: look up, multiply, round to the nearest tenth, repeat. Occasionally, there's a step where we add instead of multiplying.
The xRound function adds 0.0000001 and then uses the Round function to round to the indicated number of decimal places (to account for the weirdness of the Excel VBA round function).
You need to create a function to "wrap" your top-level dictionary so you can call it with the three "keys" and get back an error value if that combination doesn't exist.
Function DoFactorLookup(k1, k2, k3) As Variant
Dim d, d2, rv
rv = CVErr(xlErrNA) ' #N/A error value
If FactorLookup.exists(k1) Then
Set d = FactorLookup(k1)
If d.exists(k2) Then
Set d2 = d(k2)
If d2.exists(k3) Then
rv = d2(k3)
End If
End If
End If
DoFactorLookup = rv
End Function
I have been trying to write a program that will loop through all the cells in an excel sheet and if one starts with a '#' it should display a message. here's the code:
(template is a worksheet variable)
Private Function processTemplate()
Dim total As Long
total = template.UsedRange.count
Dim count As Integer
count = 0
While count <= total
If template.Cells(count).Value Like "[#]*" Then 'Here I get a error
MsgBox "Found #"
End If
count = count + 1
Wend
End Function
I have isolated the error to using a variable inside of cells(). If I replace count with some number (like 8) it works fine. I am getting error 1004 on the line If template.Cells(count).Value Like "[#]*" Then
If I make total an Integer it has the same error at the same place. After about 2-3 hrs of research/banging my head on the wall I have no idea. I initially got the error when assigning template.cells(row, col).Value to a string variable.
Here's my code now:
Private Sub processTemplate()
MsgBox Len("")
Dim str As String
Dim rows As Long
Dim cols As Long
rows = template.UsedRange.Height
cols = template.UsedRange.Width
Dim row As Integer
row = 1
While row < rows
Dim col As Integer
col = 1
While col < cols
str = template.Cells(row, col).Text
If Len(str) > 0 Then
If Left(template.Cells(row, col).Text, 1) = "#" Then
MsgBox "Found IT"
End If
End If
Rem MsgBox template.Parent.Name & ": " & template.Name & ", Cell(" & row & ", " & col & "): " & template.Cells(row, col).Value
col = col + 1
Wend
row = row + 1
Wend
End Sub
Now I get the error on str = template.Cells(row, col).Text
We can use a sub rather than a function
We loop over all the cells in UsedRange looking for a # as the first character in the cell.
Sub FindThePound()
Dim r As Range, pound As String, template As Worksheet
pound = "#"
Set template = ActiveSheet
For Each r In template.UsedRange
If Left(r.Value, 1) = pound Then
MsgBox "Found # in " & r.Address(0, 0)
End If
Next r
End Sub
EDIT#1
This version loops over all the cells, but does not test cells containing formulas
Sub FindThePound()
Dim r As Range, pound As String, template As Worksheet
pound = "#"
Set template = ActiveSheet
For Each r In template.UsedRange
If r.HasFormula = False Then
If Left(r.Value, 1) = pound Then
MsgBox "Found # in " & r.Address(0, 0)
End If
End If
Next r
End Sub
You could use find/ find next function which i guess bit faster than looping through each cell and do string comparison.
With Worksheets(1).Range("a1:a500") 'Provide the search range
Set c = .Find(2, lookin:=xlValues) ' searching for 2 in cell value
If Not c Is Nothing Then
firstAddress = c.Address 'first occurance
Do
'do whatever you want to do with the matches even replace them
c.Value = 5
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
Reference:
http://msdn.microsoft.com/en-us/library/office/ff196143(v=office.15).aspx
I am getting the impression that this is not possible in word but I figure if you are looking for any 3-4 words that come in the same sequence anywhere in a very long paper I could find duplicates of the same phrases.
I copy and pasted a lot of documentation from past papers and was hoping to find a simple way to find any repeated information in this 40+ page document there is a lot of different formatting but I would be willing to temporarily get rid of formatting in order to find repeated information.
To highlight all duplicate sentences, you can also use ActiveDocument.Sentences(i). Here is an example
LOGIC
1) Get all the sentences from the word document in an array
2) Sort the array
3) Extract Duplicates
4) Highlight duplicates
CODE
Option Explicit
Sub Sample()
Dim MyArray() As String
Dim n As Long, i As Long
Dim Col As New Collection
Dim itm
n = 0
'~~> Get all the sentences from the word document in an array
For i = 1 To ActiveDocument.Sentences.Count
n = n + 1
ReDim Preserve MyArray(n)
MyArray(n) = Trim(ActiveDocument.Sentences(i).Text)
Next
'~~> Sort the array
SortArray MyArray, 0, UBound(MyArray)
'~~> Extract Duplicates
For i = 1 To UBound(MyArray)
If i = UBound(MyArray) Then Exit For
If InStr(1, MyArray(i + 1), MyArray(i), vbTextCompare) Then
On Error Resume Next
Col.Add MyArray(i), """" & MyArray(i) & """"
On Error GoTo 0
End If
Next i
'~~> Highlight duplicates
For Each itm In Col
Selection.Find.ClearFormatting
Selection.HomeKey wdStory, wdMove
Selection.Find.Execute itm
Do Until Selection.Find.Found = False
Selection.Range.HighlightColorIndex = wdPink
Selection.Find.Execute
Loop
Next
End Sub
'~~> Sort the array
Public Sub SortArray(vArray As Variant, i As Long, j As Long)
Dim tmp As Variant, tmpSwap As Variant
Dim ii As Long, jj As Long
ii = i: jj = j: tmp = vArray((i + j) \ 2)
While (ii <= jj)
While (vArray(ii) < tmp And ii < j)
ii = ii + 1
Wend
While (tmp < vArray(jj) And jj > i)
jj = jj - 1
Wend
If (ii <= jj) Then
tmpSwap = vArray(ii)
vArray(ii) = vArray(jj): vArray(jj) = tmpSwap
ii = ii + 1: jj = jj - 1
End If
Wend
If (i < jj) Then SortArray vArray, i, jj
If (ii < j) Then SortArray vArray, ii, j
End Sub
SNAPSHOTS
BEFORE
AFTER
I did not use my own DAWG suggestion, and I am still interested in seeing if someone else has a way to do this, but I was able to come up with this:
Option Explicit
Sub test()
Dim ABC As Scripting.Dictionary
Dim v As Range
Dim n As Integer
n = 5
Set ABC = FindRepeatingWordChains(n, ActiveDocument)
' This is a dictionary of word ranges (not the same as an Excel range) that contains the listing of each word chain/phrase of length n (5 from the above example).
' Loop through this collection to make your selections/highlights/whatever you want to do.
If Not ABC Is Nothing Then
For Each v In ABC
v.Font.Color = wdColorRed
Next v
End If
End Sub
' This is where the real code begins.
Function FindRepeatingWordChains(ChainLenth As Integer, DocToCheck As Document) As Scripting.Dictionary
Dim DictWords As New Scripting.Dictionary, DictMatches As New Scripting.Dictionary
Dim sChain As String
Dim CurWord As Range
Dim MatchCount As Integer
Dim i As Integer
MatchCount = 0
For Each CurWord In DocToCheck.Words
' Make sure there are enough remaining words in our document to handle a chain of the length specified.
If Not CurWord.Next(wdWord, ChainLenth - 1) Is Nothing Then
' Check for non-printing characters in the first/last word of the chain.
' This code will read a vbCr, etc. as a word, which is probably not desired.
' However, this check does not exclude these 'words' inside the chain, but it can be modified.
If CurWord <> vbCr And CurWord <> vbNewLine And CurWord <> vbCrLf And CurWord <> vbLf And CurWord <> vbTab And _
CurWord.Next(wdWord, ChainLenth - 1) <> vbCr And CurWord.Next(wdWord, ChainLenth - 1) <> vbNewLine And _
CurWord.Next(wdWord, ChainLenth - 1) <> vbCrLf And CurWord.Next(wdWord, ChainLenth - 1) <> vbLf And _
CurWord.Next(wdWord, ChainLenth - 1) <> vbTab Then
sChain = CurWord
For i = 1 To ChainLenth - 1
' Add each word from the current word through the next ChainLength # of words to a temporary string.
sChain = sChain & " " & CurWord.Next(wdWord, i)
Next i
' If we already have our temporary string stored in the dictionary, then we have a match, assign the word range to the returned dictionary.
' If not, then add it to the dictionary and increment our index.
If DictWords.Exists(sChain) Then
MatchCount = MatchCount + 1
DictMatches.Add DocToCheck.Range(CurWord.Start, CurWord.Next(wdWord, ChainLenth - 1).End), MatchCount
Else
DictWords.Add sChain, sChain
End If
End If
End If
Next CurWord
' If we found any matching results, then return that list, otherwise return nothing (to be caught by the calling function).
If DictMatches.Count > 0 Then
Set FindRepeatingWordChains = DictMatches
Else
Set FindRepeatingWordChains = Nothing
End If
End Function
I have tested this on a 258 page document (TheStory.txt) from this source, and it ran in just a few minutes.
See the test() sub for usage.
You will need to reference the Microsoft Scripting Runtime to use the Scripting.Dictionary objects. If that is undesirable, small modifications can be made to use Collections instead, but I prefer the Dictionary as it has the useful .Exists() method.
I chose a rather lame theory, but it seems to work (at least if I got the question right cuz sometimes I'm a slow understander).
I load the entire text into a string, load the individual words into an array, loop through the array and concatenate the string, containing each time three consecutive words.
Because the results are already included in 3 word groups, 4 word groups or more will automatically be recognized.
Option Explicit
Sub Find_Duplicates()
On Error GoTo errHandler
Dim pSingleLine As Paragraph
Dim sLine As String
Dim sFull_Text As String
Dim vArray_Full_Text As Variant
Dim sSearch_3 As String
Dim lSize_Array As Long
Dim lCnt As Long
Dim lCnt_Occurence As Long
'Create a string from the entire text
For Each pSingleLine In ActiveDocument.Paragraphs
sLine = pSingleLine.Range.Text
sFull_Text = sFull_Text & sLine
Next pSingleLine
'Load the text into an array
vArray_Full_Text = sFull_Text
vArray_Full_Text = Split(sFull_Text, " ")
lSize_Array = UBound(vArray_Full_Text)
For lCnt = 1 To lSize_Array - 1
lCnt_Occurence = 0
sSearch_3 = Trim(fRemove_Punctuation(vArray_Full_Text(lCnt - 1) & _
" " & vArray_Full_Text(lCnt) & _
" " & vArray_Full_Text(lCnt + 1)))
With Selection.Find
.Text = sSearch_3
.Forward = True
.Replacement.Text = ""
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
Do While .Execute
lCnt_Occurence = lCnt_Occurence + 1
If lCnt_Occurence > 1 Then
Selection.Range.Font.Color = vbRed
End If
Selection.MoveRight
Loop
End With
Application.StatusBar = lCnt & "/" & lSize_Array
Next lCnt
errHandler:
Stop
End Sub
Public Function fRemove_Punctuation(sString As String) As String
Dim vArray(0 To 8) As String
Dim lCnt As Long
vArray(0) = "."
vArray(1) = ","
vArray(2) = ","
vArray(3) = "?"
vArray(4) = "!"
vArray(5) = ";"
vArray(6) = ":"
vArray(7) = "("
vArray(8) = ")"
For lCnt = 0 To UBound(vArray)
If Left(sString, 1) = vArray(lCnt) Then
sString = Right(sString, Len(sString) - 1)
ElseIf Right(sString, 1) = vArray(lCnt) Then
sString = Left(sString, Len(sString) - 1)
End If
Next lCnt
fRemove_Punctuation = sString
End Function
The code assumes a continuous text without bullet points.