Is there a way to dump every word and their start range and end range into an array or dictionary or etc. without looping?
I already tried the following two methods and they work,
Sub test_1()
Dim wrd As Variant
Dim TxtArray() As String
Dim i As Long
For Each wrd In ActiveDocument.Range.Words
'code to add to add to array her
Next
End Sub
and
Sub test_2()
Dim TxtArray() As String
TxtArray = Split(ActiveDocument.Range.Text)
End Sub
The split method can't give me the option to register the starting and ending range positions of each word, because I may want to highlight them later on; plus when I add words to the dictionary, I eliminate the duplicate ones
Is there a way to dump the Range.Words collection without looping? I tried but it didn't work.
"when I add words to the dictionary, I eliminate the duplicate ones" - you don't have to do that: use an array of ranges as the value for the dictionary, with the word as the key.
For example:
Sub MapWords()
Dim d As New Scripting.Dictionary
Dim wrd As Variant, tmp, ub As Long, txt As String, w
Dim i As Long
For Each wrd In ActiveDocument.Range.Words
txt = Trim(wrd.Text)
If Len(txt) > 1 Then
If Not d.Exists(txt) Then
d.Add txt, GetArray(wrd)
Else
tmp = d(txt)
ub = UBound(tmp) + 1
ReDim Preserve tmp(1 To ub)
Set tmp(ub) = wrd
d(txt) = tmp
End If
End If
Next
'e.g. -
Set w = d("split")(1)
Debug.Print w.Text, w.Start, w.End
End Sub
Function GetArray(wrd)
Dim rv(1 To 1)
Set rv(1) = wrd
GetArray = rv
End Function
Related
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
Option Explicit
Public Sub consolidateList()
DeleteTableRows (ThisWorkbook.Worksheets("Master").ListObjects("MasterSheet"))
FillTableRows
End Sub
Private Sub FillTableRows()
'set up worksheet objects
Dim wkSheet As Worksheet
Dim wkBook As Workbook
Dim wkBookPath As String
Set wkBook = ThisWorkbook
wkBookPath = wkBook.Path
Set wkSheet = wkBook.Worksheets("Master")
'set up file system objects
Dim oFile As Object
Dim oFSO As Object
Dim oFolder As Object
Dim oFiles As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder(wkBookPath)
Set oFiles = oFolder.Files
'set up loop
Dim checkBook As Excel.Workbook
Dim reportDict As Dictionary
Application.ScreenUpdating = False
'initial coordinates
Dim startRow As Long
Dim startColumn As Long
startColumn = 3
Dim i As Long 'tracks within the row of the sheet where information is being pulled from
Dim k As Long 'tracks the row where data is output on
Dim j As Long 'tracks within the row of the sheet where the data is output on
Dim Key As Variant
j = 1
k = wkSheet.Range("a65536").End(xlUp).Row + 1
Dim l As Long
'look t Set checkBook = Workbooks.Open(oFile.Path)hrough folder and then save it to temp memory
On Error GoTo debuger
For Each oFile In oFiles
startRow = 8
'is it not the master sheet? check for duplicate entries
'oFile.name is the name of the file being scanned
'is it an excel file?
If Mid(oFile.Name, Len(oFile.Name) - 3, 4) = ".xls" Or Mid(oFile.Name, Len(oFile.Name) - 3, 4) = ".xlsx" Then
Set checkBook = Workbooks.Open(oFile.Path)
For l = startRow To 600
If Not (IsEmpty(Cells(startRow, startColumn))) Then
'if it is, time do some calculations
Set reportDict = New Dictionary
'add items of the payment
For i = 0 To 33
If Not IsEmpty(Cells(startRow, startColumn + i)) Then
reportDict.Add Cells(4, startColumn + i), Cells(startRow, startColumn + i)
End If
Next i
For i = startRow To 0 Step -1
If Not IsEmpty(Cells(i, startColumn - 1)) Then
reportDict.Add "Consumer Name", Cells(i, startColumn - 1)
Exit For
End If
Next i
'key is added
For Each Key In reportDict
'wkSheet.Cells(k, j) = reportDict.Item(Key)
Dim myInsert As Variant
Set myInsert = reportDict.Item(Key)
MsgBox (myInsert)
wkSheet.ListObjects(1).DataBodyRange(2, 1) = reportDict.Item(Key)
j = j + 1
Next Key
wkSheet.Cells(k, j) = wkSheet.Cells(k, 9) / 4
wkSheet.Cells(k, j + 1) = oFile.Name
'
k = k + 1
' Set reportDict = Nothing
j = 1
Else
l = l + 1
End If
startRow = startRow + 1
Next l
checkBook.Close
End If
' Exit For
Next oFile
Exit Sub
debuger:
MsgBox ("Error on: " & Err.Source & " in file " & oFile.Name & ", error is " & Err.Description)
End Sub
Sub DeleteTableRows(ByRef Table As ListObject)
On Error Resume Next
'~~> Clear Header Row `IF` it exists
Table.DataBodyRange.ClearContents
'~~> Delete all the other rows `IF `they exist
Table.DataBodyRange.Offset(1, 0).Resize(Table.DataBodyRange.Rows.count - 1, _
Table.DataBodyRange.Columns.count).Rows.Delete
On Error GoTo 0
End Sub
Greetings. The above code consolidates a folder of data that's held on excel spreadsheets into one master excel spreadsheet. The goal is to run a macro on Excel Spreadsheet named master on the worksheet named master which opens up other excel workbooks in the folder, takes the information, and puts it into a table in the worksheet "master". After which point, it becomes easy to see the information; so instead of it being held on hundreds of worksheets, the records are held on one worksheet.
The code uses a dictionary (reportDict) to temporarily store the information that is needed from the individual workbooks. The goal then is to take that information and place it in the master table at the bottom row, and then obviously add a new row either after a successful placement or before an attempted placement of data.
The code fails at the following line:
wkSheet.ListObjects(1).DataBodyRange(2, 1) = reportDict.Item(Key)
The failure description is "object or with variable not set" and so the issue is with the reportDict.Item(Key). My guess is that somehow VBA is not recognizing the dictionary item as stable, but I don't know how to correct this. Eventually the goal is to have code which does:
for each key in reportDict
- place the item which is mapped to the key at a unique row,column in the master table
- expand the table to accomodate necessary data
next key
Implicit default member calls are plaguing your code all over.
reportDict.Add Cells(4, startColumn + i), Cells(startRow, startColumn + i)
That's implicitly accessing Range.[_Default] off whatever worksheet is currently the ActiveSheet (did you mean that to be wkSheet.Cells?), to get the Key - since the Key parameter is a String, Range.[_Default] is implicitly coerced into one, and you have a string key. The actual dictionary item at that key though, isn't as lucky.
Here's a MCVE:
Public Sub Test()
Dim d As Dictionary
Set d = New Dictionary
d.Add "A1", Cells(1, 1)
Debug.Print IsObject(d("A1"))
End Sub
This procedure prints True to the debug pane (Ctrl+G): what you're storing in your dictionary isn't a bunch of string values, but a bunch of Range object references.
So when you do this:
Dim myInsert As Variant
Set myInsert = reportDict.Item(Key)
You might as well have declared myInsert As Range, for it is one.
This is where things get interesting:
MsgBox (myInsert)
Nevermind the superfluous parentheses that force-evaluate the object's default member and pass it ByVal to the MsgBox function - here you're implicitly converting Range.[_Default] into a String. That probably works.
So why is this failing then?
wkSheet.ListObjects(1).DataBodyRange(2, 1) = reportDict.Item(Key)
Normally, it wouldn't. VBA would happily do this:
wkSheet.ListObjects(1).DataBodyRange.Cells(2, 1).[_Default] = reportDict.Item(Key).[_Default]
And write the value in the DataBodyRange of the ListObject at the specified location.
I think that's all just red herring. Write explicit code: if you mean to store the Value of a cell, store the Value of a cell. If you mean to assign the Value of a cell, assign the Value of a cell.
I can't replicate error 91 with this setup.
This, however:
DeleteTableRows (ThisWorkbook.Worksheets("Master").ListObjects("MasterSheet"))
...is also force-evaluating a ListObject's default member - so DeleteTableRows isn't receiving a ListObject, it's getting a String that contains the name of the object you've just dereferenced... but DeleteTableRows takes a ListObject parameter, so there's no way that code can even get to run FillTableRows - it has to blow up with a type mismatch before DeleteTableRows even gets to enter. In fact, it's a compile-time error.
So this is a rather long answer that doesn't get to the reason for error 91 on that specific line (I can't reproduce it), but highlights a metric ton of serious problems with your code that very likely are related to this error you're getting. Hope it helps.
You need to iterate through the dictionary's Keys collection.
dim k as variant, myInsert As Variant
for each k in reportDict.keys
debug.print reportDict.Item(k)
next k
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.
Just like you can copy an arbitrary number of lines from a text document and paste into Excel in successive rows, I want to be able to copy the lines of text and paste them into the comments of successive rows in Excel. To make it a bit easier, I paste the rows of comment text from the .txt file into a column in Excel first. This is what I'm looking at right now:
Dim myClip As New DataObject
Dim myString As String
myClip.GetFromClipboard
myString = myClip.GetText
Sheet1.Range("A1").AddComment myString
but pasting from the clipboard like this doesn't seem to have to the desired effect. Any ideas?
Sub AddCommentsToSelection()
Dim myClip As New DataObject
Dim myString As String
Dim c As Range, arr, x As Integer
myClip.GetFromClipboard
myString = myClip.GetText
If Len(myString) = 0 Then Exit Sub
Set c = Selection.Cells(1)
arr = Split(myString, vbCrLf)
For x = LBound(arr) To UBound(arr)
c.AddComment arr(x)
Set c = c.Offset(1, 0)
Next x
End Sub
Sub Driver()
'Highlights driver who have 1 point
Dim driverData ' array variable to hold driver names
driverData = Range("C2:C391").Value
ReDim driverData(390)
MsgBox driverData(3)
Though Range("C2:C391") has values in the worksheet, the array seems to be having only blanks
So, using the MsgBox command, only a blank appears
When you use just ReDim you clober all the contents in the array. You need to use ReDim Preserve to keep elements that are in the array.
That being said, the you can't simply redim a 2D array into a 1D array. You can do this:
Sub test()
Dim driverData As Variant
Dim newArray() As String
driverData = Range("C2:C391").Value
ReDim newArray(1 To UBound(driverData, 1))
For i = 1 To UBound(driverData)
newArray(i) = driverData(i, 1)
Next
MsgBox newArray(3)
End Sub
You can;
Dim driverData as Variant
driverData = Range("C2:C391")
msgbox driverData(3, 1)
(As you have it, you cannot assign a Range.value to an array, and even if you could the ReDim would erase its contents)