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.
Related
I am writing Word VBA that:
(1) assigns values from a Word table to VBA variables,
(2) cleans the variables' values of non-text,
(3) uses the variables' names and values to create Bookmarks in that same bookmark_value cell of the table, and
(4) repeats 1-2-3 until the end of table.
This table is the first table in the document and has two columns, something like this:
_________________________________
| bookmark_name | bookmark_value|
| bm1 | 88 |
| foo | 66 |
|_____bar_______|______44_______|
The code picks up the bookmark_names and posts into Word Bookmarks, and also picks up the bookmark_values but fails to clean the table coding out of the value.
The result is the Bookmarks displaying these unwanted cells in Word with the value inside it. It is strange that first column works and not the second.
Some things I tried:
I found on the Internet and on this site, what I thought were solutions, those are marked in the code below with comments, the header saying, "tried and failed".
I am nearly sure I need to "unformat" the text, or something like that.
Public Sub BookmarkTable()
Dim selectedTable As Table
Dim curRow As Range
Dim rngSelect1 As Range
Dim rngSelect2 As Range
Dim intTableIndex As Integer
Dim rng As Range
Dim Cell1 As Cell, Cell2 As Cell
Dim strBookmarkName As String, strBookmarkValue As String, strBV As String
Dim strTstBookmark As String
Dim Col1 As Integer, Col2 As Integer
Dim i As Integer, t As Integer
Dim intRow As Integer
' Dim
Col1 = 1 'set the bookmark name from column 1
Col2 = 2 'set the bookmark's value from column 2
'For t = 1 To ActiveDocument.Tables.Count
t = 1 'select the Table to use(only using the first table right now)
Set selectedTable = ActiveDocument.Tables(t)
selectedTable.Select 'selects the table
For intRow = 2 To selectedTable.Rows.Count 'iterate through all rows
If Selection.Information(wdWithInTable) Then
Set Cell1 = ActiveDocument.Tables(t).Cell(intRow, Col1)
Set Cell2 = ActiveDocument.Tables(t).Cell(intRow, Col2)
Cell2.Select
intTableIndex = ActiveDocument.Range(0, Selection.Tables(1).Range.End).Tables.Count
rngColumnStart = Selection.Information(wdStartOfRangeColumnNumber)
rngRowStart = Selection.Information(wdStartOfRangeRowNumber)
End If
strTstBookmark = "BM_Table" & CStr(intTableIndex) & "_R" & CStr(rngRowStart) & "_C" & CStr(rngColumnStart)
' strBookmarkValue = strTstBookmark
Set rngSelect1 = ActiveDocument.Range(Start:=Cell1.Range.Start, End:=Cell1.Range.End - 1)
strBookmarkName = Strip(rngSelect1.Text)
Set rngSelect2 = ActiveDocument.Range(Start:=Cell2.Range.Start, End:=Cell2.Range.End - 1)
strBookmarkValue = Strip(rngSelect2.Text)
Set rng = ActiveDocument.Tables(intTableIndex).Cell(rngRowStart, rngColumnStart).Range
rng.End = rng.End - 1
'--------------------------------------------------------------------------
'tried and failed)
'--------------------------------------------------------------------------
'Stop
If ActiveDocument.Bookmarks.Exists(strBookmarkName) = True Then
ActiveDocument.Bookmarks(strBookmarkName).Delete
End If
If ActiveDocument.Bookmarks.Exists(strTstBookmark) = True Then
ActiveDocument.Bookmark(strTstBookmark).Delete
End If
ActiveDocument.Bookmarks.Add Name:=strTstBookmark
ActiveDocument.Bookmarks.Add Name:=strBookmarkName
ActiveDocument.Bookmarks(strBookmarkName).Range.Text = strBookmarkValue
Next intRow
'Next t
End Sub
'--------------------------------------------------------------------------
'tried and failed
Private Function Strip(ByVal fullest As String)
' fuller = Left(fullest, Len(s) - 2)
Strip = Trim(Replace(fullest, vbCr & Chr(7), ""))
End Function
'--------------------------------------------------------------------------
That's truly horrible code you're using. Try:
Sub BkMkDemo()
Application.ScreenUpdating = False
Dim r As Long, BkMkNm As String, BkMkTxt As String
With ActiveDocument
For r = 2 To .Tables(1).Rows.Count
BkMkNm = Split(.Tables(1).Cell(r, 1).Range.Text, vbCr)(0)
BkMkTxt = Split(.Tables(1).Cell(r, 2).Range.Text, vbCr)(0)
If Not .Bookmarks.Exists(BkMkNm) Then .Bookmarks.Add BkMkNm, .Range.Characters.Last
Call UpdateBookmark(BkMkNm, BkMkTxt)
Next
End With
Application.ScreenUpdating = True
End Sub
Sub UpdateBookmark(BkMkNm As String, BkMkTxt As String)
Dim BkMkRng As Range
With ActiveDocument
If .Bookmarks.Exists(BkMkNm) Then
Set BkMkRng = .Bookmarks(BkMkNm).Range
BkMkRng.Text = BkMkTxt
.Bookmarks.Add BkMkNm, BkMkRng
End If
End With
Set BkMkRng = Nothing
End Sub
If all you want to do is to apply the bookmark to the content of the second cell, you need nothing more complex than:
Sub BkMkDemo()
Application.ScreenUpdating = False
Dim r As Long, BkMkNm As String, BkMkRng As Range
With ActiveDocument
For r = 2 To .Tables(1).Rows.Count
BkMkNm = Split(.Tables(1).Cell(r, 1).Range.Text, vbCr)(0)
Set BkMkRng = .Tables(1).Cell(r, 2).Range
BkMkRng.End = BkMkRng.End - 1
.Bookmarks.Add BkMkNm, BkMkRng
Next
End With
Application.ScreenUpdating = True
End Sub
After a great deal of research and learning by this VBA neophyte, here is the solution that I finally got to work. I found the fix by accident on the Windows Dev Center at msdn dot microsoft dot com posted by Cindy Meister...thank you. Turns out there are a combination of three characters needing to be cleaned when extracting text from a Word table cell: Chr(10) & Chr(13), Chr(11).
I simplified the code using the suggestions of macropod above. Thank you.
Sub aBookmarkTable()
'
'a subroutine compiled by Steven McCrary from various sources
'on the Internet, to use values in the second column of the
'first table in a Word document to create Bookmarks in that second
'column, in place of the value input there.
'
'To use the macros, modify the values in the table and run the macro.
'Then place Field Code references in Word to use the Bookmarks.
'The Bookmarks can be seen through Word menu: Insert>Links>Bookmark
'
'The table has just two columns, looking something like this:
'_________________________________
'| bookmark_name | bookmark_value|
'| bm1 | 88 |
'| foo | 66 |
'|_____bar_______|______44_______|
'
'The code places each Bookmark in the second column of each row, using
'the name given in the first column.
'
'The two critical functions of the macro occur in these two lines of code:
' rngBM.End = rngBM.End - 1
' Strip = Replace(fullest, Chr(10) & Chr(13), Chr(11))
'
' both are explained below where they are used.
Application.ScreenUpdating = False
Dim rng1 As Range, rng2 As Range, rngBM As Range
Dim Cell_1 As Cell, Cell_2 As Cell
Dim strBMName As String, strBMValue As String
Dim r As Integer
Call RemoveBookmarks 'removing bookmarks helped to simlify the coding
With ActiveDocument
For r = 2 To .Tables(1).Rows.Count 'iterate through all rows
Set Cell_1 = ActiveDocument.Tables(1).Cell(r, 1)
Set Cell_2 = ActiveDocument.Tables(1).Cell(r, 2)
Cell_2.Select
Set rng1 = .Range(Cell_1.Range.Start, Cell_1.Range.End - 1)
strBMName = Strip(rng1.Text)
Set rng2 = .Range(Cell_2.Range.Start, Cell_2.Range.End - 1)
Set rngBM = ActiveDocument.Tables(1).Cell(r, 2).Range
'When using data contained in a cell of a Word table,
'grabbing the cell's contents also grabs several other
'characters, which therefore need removed in two steps.
'
'The first step is to clean the extra characters from the text.
strBMValue = Strip(rng2.Text)
'
'The second step is to decrease the range size to put in the
'Bookmark.
rngBM.End = rngBM.End - 1
rngBM.Text = strBMValue
.Bookmarks.Add strBMName, rngBM
Next r
End With
Application.ScreenUpdating = True
Selection.WholeStory
ActiveDocument.Fields.Update
End Sub
Sub RemoveBookmarks()
Dim bkm As Bookmark
For Each bkm In ActiveDocument.Bookmarks
bkm.Delete
Next bkm
End Sub
Private Function Strip(ByVal fullest As String)
' the next line of code is the tricky part of the clean
' process because of how Word formats tables and text
' ASCII code Chr(10) is Line Feed
' Chr(13) is Carriage Return
' Chr(13) + Chr(10): vbCrLf or vbNewLine New line character
' Chr (11) is Vertical Tab, but per Word VBA Manual -
' manual line break (Shift + Enter)
'
Strip = Replace(fullest, Chr(10) & Chr(13), Chr(11))
End Function
Thank you again.
SWM
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
I need to be able to identify the worksheet that an excel chart (on a worksheet) is getting it's data from. I only need the data sheet which series 1 is referencing. I've started trying to extract the sheet name from .SeriesCollection(1).Formula but it gets realy complex. here's what I've got so far:
Sub GetChartDataSheet()
Dim DataSheetName As String
Dim DataSheet As Worksheet
DataSheetName = ActiveChart.SeriesCollection(1).Formula
DataSheetName = Left(DataSheetName, InStr(1, DataSheetName, "!$") - 1)
DataSheetName = WorksheetFunction.Replace(DataSheetName, 1, Len("=series("), "")
If Left(DataSheetName, 1) = "'" And Right(DataSheetName, 1) = "'" Then DataSheetName = Mid(DataSheetName, 2, Len(DataSheetName) - 2)
DataSheetName = Replace(DataSheetName, "''", "'")
Set DataSheet = Sheets(DataSheetName)
End Sub
this works in a lot of cases, but if my users have a strange worksheet name (eg Sh'e e$,,t!3!$) it fails. the same goes if series 1 has been named (eg .SeriesCollection(1).Formula = "=SERIES(**"Hell,o !"**,'Sh''e e$,,t!3!$'!$B$2:$B$18,'Sh''e e$,,t!3!$'!$C$2:$C$18,1)".
Is there a simple way to solve this?
I thought this is an easy one, turns out it's not. One of the cases where Excel has the information but will not give it away for free. I ended up with a function like this - maybe this helps:
Function getSheetNameOfSeries(s As Series) As String
Dim f As String, i As Integer
Dim withQuotes As Boolean
' Skip leading comma if not all parts of series is filled. Check if sheetname is in single quotes
For i = 9 To Len(s.Formula)
If Mid(s.Formula, i, 1) <> "," Then
If Mid(s.Formula, i, 1) = "'" Then
withQuotes = True
f = Mid(s.Formula, i + 1)
Else
withQuotes = False
f = Mid(s.Formula, i)
End If
Exit For
End If
Next i
' "f" now contains a part of the formula with the sheetname as start
' now we search to the end of the sheet name.
' If name is in quotes, we are looking for the "closing" quote
' If not in quotes, we are looking for "!"
i = 1
Do While True
If withQuotes Then
' Sheet name is in quotes, found closes quote --> we're done
' (but if next char is also a quote, we have the case the the sheet names contains a quote, so we have to continue working)
If Mid(f, i, 1) = "'" Then
If Mid(f, i + 1, 1) <> "'" Then
getSheetNameOfSeries = Mid(f, 1, i - 1)
Exit Do
Else
i = i + 1 ' Skip 2nd quote
End If
End If
Else
' Sheet name is quite normal, so "!" will indicate the end of sheetname
If Mid(f, i, 1) = "!" Then
getSheetNameOfSeries = Mid(f, 1, i - 1)
Exit Do
End If
End If
i = i + 1
Loop
getSheetNameOfSeries = Replace(getSheetNameOfSeries, "''", "'")
End Function
You can use the Find function to look for the values of SeriesCollection(1).
In the worksheet that hold the data of SeriesCollection(1), you will be able to find all the values in that array.
More explanations inside the code below.
Code
Option Explicit
Sub GetChartDataSheet()
Dim DataSheetName As String
Dim DataSheet As Worksheet
Dim ws As Worksheet
Dim ValuesArr As Variant, Val As Variant
Dim FindRng As Range
Dim ShtMatch As Boolean
Dim ChtObj As ChartObject
Dim Ser As Series
' if you want to use ActiveChart
Set ChtObj = ActiveChart.Parent
Set Ser = ChtObj.Chart.SeriesCollection(1)
ValuesArr = Ser.Values ' get the values of the Series Collection inside an array
' use Find to get the Sheet's origin
For Each ws In ThisWorkbook.Sheets
With ws
ShtMatch = True
For Each Val In ValuesArr ' loop through all values in array
Set FindRng = .Cells.Find(what:=Val) ' you need to find each value in the worksheet that SeriesCollection data is tied to
If FindRng Is Nothing Then
ShtMatch = False
Exit For
End If
Set FindRng = Nothing ' reset
Next Val
If ShtMatch = True Then
Set DataSheet = ws
Exit For
End If
End With
Next ws
DataSheetName = DataSheet.Name
End Sub
Good day! in my worksheet i have (1) textbox as TextBox1 and 1 button for submit button. I have here sample code that gives splitted text as an output. I just want that if there's duplicated word in textbox1 and the user enters the submit button it will saves to worksheet(DatabaseStorage) and categorize the output from No Duplicated Word and With duplicated Word. Because this two different fields will be needed for some function of the system.
Private Sub CommandButton1_Click()
Call SplitText
End Sub
Sub SplitText()
Dim WArray As Variant
Dim TextString As String
TextString = TextBox1
WArray = Split(TextBox1, " ")
If (TextString = "") Then
MsgBox ("Error: Pls Enter your data")
Else
With Sheets("DatabaseStorage")
.Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(UBound(WArray) + IIf(LBound(WArray) = 0, 1, 0)) = Application.Transpose(WArray)
End With
MsgBox ("Successfully inserted")
End If
End Sub
This should accomplish what you need. I loop through the array to check if the given value exists in the "No Duplicates" column. If not, don't print it there.
Any time I encounter a situation where I need to check a single value against a list (ex. check for duplicates, GT/LT, etc.), I consider looping.
Sub SplitText()
Dim WArray As Variant
Dim TextString As String
Dim col_no_dup As Long
Dim col_dup As Long
Dim counter As Integer
Dim sht_database As Worksheet
With ThisWorkbook
Set sht_database = .Sheets("DatabaseStorage")
TextString = LCase(.Sheets("Sheet1").Shapes("Textbox1").DrawingObject.Text)
End With
WArray = Split(TextString, " ") 'load array
If (TextString = "") Then
MsgBox ("Error: Pls Enter your data")
End
Else: End If
'set column locations for duplicates/no duplicates
col_no_dup = 1
col_dup = 2
With sht_database
.Range("A2:B10000").ClearContents 'clear existing data. Change this as needed
'Print whole array into duplicates column
.Cells(Cells.Rows.Count, col_dup).End(xlUp).Offset(1, 0).Resize(UBound(WArray) + IIf(LBound(WArray) = 0, 1, 0)) = Application.Transpose(WArray)
'Loop through array
For i = LBound(WArray) To UBound(WArray)
counter = 0
lrow_no_dup = .Cells(Cells.Rows.Count, col_no_dup).End(xlUp).Row
For n = 1 To lrow_no_dup 'loop through and check each existing value in the no dup column
If .Cells(n, col_no_dup).Value = WArray(i) Then
counter = counter + 1 'account for each occurence
Else: End If
Next n
If counter = 0 Then 'counter = 0 implies the value doesn't exist in the "No Duplicates" column
.Cells(lrow_no_dup + 1, col_no_dup).Value = WArray(i)
Else: End If
Next i
End With
MsgBox ("Successfully inserted")
End Sub
Context: I'm writing a Word VBA macro that loops through each word in a document, identifies the acronyms, and creates an acronym list as a new document. The next step is to identify whether the acronym is in parentheses (meaning it's likely spelled out) on its first occurrence. So, I'd like to expand the range to find out whether the characters on either side of the word are "(" and ")".
Issue: I can't figure out how to assign the range of the word to a range variable that I can then expand. Using "rngWord = ActiveDocument.Words(k)" (where k is the counter variable) gets the error #91, Object Variable or With block variable not set. So presumably there's a method or property for Words that I'm missing. Based on Microsoft's VBA reference, though, the members of the Words collection are already ranges, so I'm stumped on why I can't assign one to a range variable.
Dim intArrayCount As Integer
Dim booAcroMatchesArray As Boolean
Dim intNextAcro As Integer
Dim strAcros(1000) As String
Dim strContext(1000) As String
Dim booAcroDefined(1000) As Boolean
Dim strTestMessage As String
i = 1
booAcroMatchesArray = False
intNextAcro = 1
For k = 1 To ActiveDocument.Words.Count
strWord = ActiveDocument.Words(k).Text
rngWord = ActiveDocument.Words(k) //The line that's missing something
MsgBox strWord
rngWord.Expand Unit:=wdCharacter
strWordPlus = rngWord
MsgBox strWordPlus
strWord = Trim(strWord)
If strWord = UCase(strWord) And Len(strWord) >= 2 And IsLetter(Left(strWord, 1)) = True Then
'MsgBox ("Word = " & strWord & " and Length = " & Len(strWord))
For intArrayCount = 1 To 1000
If strWord = strAcros(intArrayCount) Then booAcroMatchesArray = True
Next intArrayCount
'MsgBox ("Word = " & strWord & " Match = " & booAcroMatchesArray)
If booAcroMatchesArray = False Then
strAcros(intNextAcro) = strWord
intNextAcro = intNextAcro + 1
End If
booAcroMatchesArray = False
End If
Next k
Object variables need to be assigned using Set. Instead of:
rngWord = ActiveDocument.Words(k)
use
Set rngWord = ActiveDocument.Words(k)
This small sample worked correctly:
Sub WordRangeTest()
Dim rngWord As Range
Set rngWord = ActiveDocument.Words(1)
MsgBox (rngWord.Text)
End Sub