I need to build a list of superscripts in a document which is fine until I get to symbols for things like partial derivatives which instead return as ? in my array instead of ∂. What could I add to capture the actual symbol? Thanks
Dim i As Long, j As String
Dim txtboxString() As String
Dim Superscript As String
Dim myrange As range
Dim ap As Document: Set ap = ActiveDocument
x = 0
For i = 1 To ap.Characters.Count
j = ""
If ActiveDocument.Characters(i).Font.Superscript = True Then
Z = 0
ReDim Preserve txtboxString(x + 1)
For Z = i To i - 5 Step -1
If Z > ap.Characters.Count Then GoTo 1
If ActiveDocument.Characters(Z) = "," Then GoTo 0
If ActiveDocument.Characters(Z).Font.Superscript = True Then j = ActiveDocument.Characters(Z) & j
Next Z
End If
0: If j <> "" Then
If j <> "," Then
If j <> "?" Then
txtboxString(x) = j
x = x + 1
End If
End If
End If
If Z + 1 > ap.Characters.Count Then i = Z 'Else i = Z + 1
Set myrange = ActiveDocument.Characters(i + 1)
myrange.MoveUntil Cset:="* "
i = myrange.End - 1
Next
Related
So I know this is long and not the prettiest, but what I am trying to accomplish is to cycle through a list of tables and look for a bookmark that I have placed in certain tables in the document. These tables have the ability to be anywhere in the doc, so I am looping through all and looking for each possible bookmark on each table.
Right now, the below is my current code. objDoc returns the correct Doc name and opens the correct Doc. The problem is after that, when the code cycles through the tables in that Doc, it does not see my Bookmarks. I have verified it is selecting the correct Doc and tables with this code. When I use the 'ActiveDoc' operator after 'objDoc.Activate', it selects the Doc I am running the code from, not objDoc where I meaning to perform this search. If I run this as a test macro in the Doc connected to objDoc outside of the below code, all variables assign correctly.
Please help, this is driving me crazy, thank you!
P.S. - also any help on slimming this down is welcome!
Dim objDoc As Document
Set objDoc = objWord.Documents.Open(strPath)
Dim fileName As String
fileName = Dir(strPath)
objDoc.Activate
Dim x As Long
Dim data0, data1, data2, data3, data4, data5, data6, data7, data8, data9, data10, data11, data12, data13, data14, data15, data16 As Long
x = 0
Dim J As Integer
Dim iTableNum As Integer
Dim oTbl As Table
objDoc.Activate
iTableNum = objDoc.Tables.Count
For J = 1 To objDoc.Tables.Count
Set oTbl = objDoc.Tables(J)
tryagain:
oTbl.Select
objDoc.Tables(J).Select ''''''ERROR LINE
If Selection.Bookmarks.Exists("data" & x) And x < 17 Then
iTableNum = objDoc.Tables.Count
'Exit For
If x = 0 Then
data0 = J
ElseIf x = 1 Then
data1 = J
ElseIf x = 2 Then
data2 = J
ElseIf x = 3 Then
data3 = J
ElseIf x = 4 Then
data4 = J
ElseIf x = 5 Then
data5 = J
ElseIf x = 6 Then
data6 = J
ElseIf x = 7 Then
data7 = J
ElseIf x = 8 Then
data8 = J
ElseIf x = 9 Then
data9 = J
ElseIf x = 10 Then
data10 = J
ElseIf x = 11 Then
data11 = J
ElseIf x = 12 Then
data12 = J
ElseIf x = 13 Then
data13 = J
ElseIf x = 14 Then
data14 = J
ElseIf x = 15 Then
data15 = J
Else
data16 = J
Exit For
End If
ElseIf x < 17 Then
x = x + 1
GoTo tryagain
End If
x = 0
Next J
x = 0
Something like this might be a little easier to manage:
Sub Tester()
Dim objDoc As Document, strPath As String
Dim x As Long, J As Long
Dim data(0 To 16) As Long
strPath = "some path here"
Set objDoc = Documents.Open(strPath)
For J = 1 To objDoc.Tables.Count 'loop over tables
With objDoc.Tables(J)
For x = LBound(data) To UBound(data) 'loop bookmarks
If .Range.Bookmarks.Exists("data" & x) Then data(x) = J
Next x
End With
Next J
'show the results
For x = LBound(data) To UBound(data)
Debug.Print x, data(x)
Next x
End Sub
There is no need to loop through the tables to find the bookmark. There can only be one bookmark of a given name in a document, so either it exists or it doesn't. Hence, there is no need to loop through all the tables and again through all the bookmarks for each table:
With objDoc
For x = LBound(Data) To UBound(Data) 'loop bookmarks
If .Bookmarks.Exists("data" & x) Then
If .Bookmarks("data" & x).Range.Information(wdWithInTable) = True Then
Data(x) = .Range(0, .Bookmarks("data" & x).Range.End).Tables.Count
End If
End If
Next x
End With
There is potential for further simplification (eliminating If tests) if you know that all the bookmarks exist and/or that any that do exist are in tables.
I'm trying to find the values in different points of the array. When I run the code, it always goes to The value doesn't exists, also I do not know how to count the values that are same r.
r = 0
c = txtbbus.Text
For i = 0 To n - 1
For j = 0 To n - 1
If a(i, j) = c Then
txtbres.Text = "The value exists " & r & " and it's in the position (" & i & ", " & j & ") "
Else
txtbres.Text = "The value doesn't exists"
End If
Next j
Next i
And this is how I initialize a:
txtbmatriz.Text = ""
For i = 0 To n - 1
For j = 0 To n - 1
a(i, j) = CInt((100 * Rnd()) + 1)
txtbmatriz.Text += a(i, j) & " "
m += a(i, j)
l += 1
Next j
txtbmatriz.Text += vbCrLf
Next i
The problem is almost certainly that you don't break out of the loop when you find a match. Your code will only ever show you the result of the last element in the array because you always keep searching to the last element. Once you find a match, there's no point to looking further and, in fact, doing so is detrimental. Once you find a match, stop looking.
Finding a single/first match:
Dim rng As New Random
Dim matrix = New Integer(9, 9) {}
For i = 0 To matrix.GetUpperBound(0)
For j = 0 To matrix.GetUpperBound(1)
matrix(i, j) = rng.Next(1, 101)
Next
Next
Dim target = rng.Next(1, 101)
Dim message As String
For i = 0 To matrix.GetUpperBound(0)
For j = 0 To matrix.GetUpperBound(1)
If matrix(i, j) = target Then
message = $"{target} found at ({i},{j})"
Exit For
End If
Next
If message IsNot Nothing Then
Exit For
End If
Next
Console.WriteLine(If(message, $"{target} not found"))
Finding all matches:
Dim rng As New Random
Dim matrix = New Integer(9, 9) {}
For i = 0 To matrix.GetUpperBound(0)
For j = 0 To matrix.GetUpperBound(1)
matrix(i, j) = rng.Next(1, 101)
Next
Next
Dim target = rng.Next(1, 101)
Dim matches As New List(Of String)
For i = 0 To matrix.GetUpperBound(0)
For j = 0 To matrix.GetUpperBound(1)
If matrix(i, j) = target Then
matches.Add($"({i},{j})")
End If
Next
Next
Console.WriteLine(If(matches.Any(),
$"{target} found at {String.Join(", ", matches)}",
$"{target} not found"))
Try this:
r = 0
c = txtbbus.Text
Dim i As Integer
Dim j As Integer
Dim FoundMatch As Boolean = False
For i = 0 To n - 1
For j = 0 To n - 1
If a(i, j) = c Then
FoundMatch = True
Exit For
End If
Next j
If FoundMatch = True Then
Exit For
End If
Next i
If FoundMatch = True Then
txtbres.Text = "The value exists " & r & " and it's in the position (" & i & ", " & j & ") "
Else
txtbres.Text = "The value doesn't exists"
End If
I'm going to assume c = txtbbus.Text is from some form input. Meaning a string. For the equality check you'd be testing against an Int type. Try casting the input from txtbbus.Text as an integer. Also, like the other poster said breaking from the loop on finding your match would also be a good decision.
I want to sort below Two-digit array by VBA code
A 1
B 2
A 1
C 3
or below:
1 A
2 B
1 A
3 C
I have tried to sort them by Dictionary, but, Dictionary is not allowed to insert duplate key.
Is there any want to sort above array by number 1,2,3
I made this some time ago, it might help.
Function ArraySorter(ByVal RecArray As Variant, Optional ByVal RefCol As Integer = 0) As Variant
Dim Menor As String
Dim NewArray() As Variant
Dim i As Double, j As Double
Dim menorIndex As Double
Dim NewArrayIndex() As Double
Dim UsedIndex() As Double
ReDim NewArrayIndex(UBound(RecArray, 2))
ReDim NewArray(UBound(RecArray), UBound(RecArray, 2))
For i = 0 To UBound(NewArrayIndex)
NewArrayIndex(i) = -1
Next i
UsedIndex = NewArrayIndex
For i = 0 To UBound(RecArray, 2)
Menor = ""
menorIndex = -1
For j = 0 To UBound(RecArray, 2)
If UsedIndex(j) = -1 Then
If Menor = "" Then
Menor = RecArray(RefCol, j)
menorIndex = j
Else
If RecArray(RefCol, j) < Menor Then
Menor = RecArray(RefCol, j)
menorIndex = j
End If
End If
End If
Next j
UsedIndex(menorIndex) = 1
NewArrayIndex(i) = menorIndex
Next i
For i = 0 To UBound(NewArrayIndex)
For j = 0 To UBound(NewArray)
NewArray(j, i) = RecArray(j, NewArrayIndex(i))
Next j
Next i
ArraySorter = NewArray
End Function
If you have something like:
Function testArraySorter()
Dim myArr() As Variant
ReDim myArr(1, 3)
myArr(0, 0) = "A"
myArr(0, 1) = "B"
myArr(0, 2) = "A"
myArr(0, 3) = "C"
myArr(1, 0) = 1
myArr(1, 1) = 2
myArr(1, 2) = 1
myArr(1, 3) = 3
myArr = ArraySorter(myArr)
For i = 0 To UBound(myArr, 2)
Debug.Print myArr(0, i), myArr(1, i)
Next i
End Function
you'll get this in your immediate verification :
A 1
A 1
B 2
C 3
If you need to sort based in two or more columns, you could add a dummy column into your array, concatenate the criteria columns into it and then set this dummy column as RefCol: myArr = ArraySorter(myArr, addedColNumberHere).
Hope this helps.
I am trying to construct and If statement that turns a tab Red if two of three cells are colored, or Turns green if only on is colored. I was hoping that there would be an easier way to right it than three if statements like this.
Dim dateRng As String, num As Integer, j As Integer, irng As Range, frng As Range
dateRng = Sheets("Input Raw Data").Range("B" & counter + 2).Value
num = Sheets("Tool Setup").Range("C18").Value
NumPts = num * 3
For s = 1 To Sheets.Count
With Sheets(s)
For j = 1 To num
If .Name = j Then
.Range("A1:C1").Merge
.Range("A1") = dateRng
.Name = Sheets("Point Names").Range("B" & (3 * j - 1))
End If
Next j
End With
Next s
For s = 1 to Sheets.Count
With Sheets(s)
For y = 1 To NumPts
If .Name = Sheets("Reporting").Range("B" & (12 * y - 5)) Then
For k = 6 To -1
Set irng = Sheets("Reporting").Range("A" & (12 * y - k))
Set irng = Sheets("Reporting").Range(irng, irng.End(xlToRight).End(xlToRight))
irng.Copy (.Range("A2"))
Next k
.Columns("A:A").ColumnWidth = 12
.Columns("B:B").EntireColumn.AutoFit
If .Range("B7").Interior.ColorIndex > 0 Then
a = 1
End If
If .Range("B8").Interior.ColorIndex > 0 Then
a = a + 1
End If
If .Range("B9").Interior.ColorIndex > 0 Then
a = a + 1
End If
If a >= 2 Then
.Tab.ColorIndex = 3
ElseIf a <= 1 Then
.Tab.ColorIndex = 4
End If
End If
y = y + 2
Next y
End With
Next s
Something like this may help you. It still has multiple if statements. But the statements are simple and don't have to deal with how the combinations of different cells being colored.
Also, I used colorindex > 0 as the condition for having color filling.
a = 0
If .Range("B7").Interior.ColorIndex > 0 Then
a = 1
End If
If .Range("B8").Interior.ColorIndex > 0 Then
a = a + 1
End If
If .Range("B9").Interior.ColorIndex > 0 Then
a = a + 1
End If
If a = 2 Then
.Range("B10").Interior.ColorIndex = 3
ElseIf a = 1 Then
.Range("B10").Interior.ColorIndex = 43
End If
This is an error I've been trying to figure out for awhile now, my find method is not producing any results and I cannot figure out why.
The code is suppose to search InputSheet for a string, report the row number and start moving information over to Background based on that row number. Then the next .find will find the string in SummaryResults and start moving information from Background, reformat it a bit, and paste to SummaryResults.
My find method is not producing any results and leaves FindRow = Nothing even though the strings are present in the sheets and in the correct Ranges.
This error started occurring after running the macro with another Excel sheet open so maybe the ActiveWorkbook was incorrect, but I have not been able to get it to run since.
Some of the variables shown are from other sections of the code but when I hover over them in the debug mode they are showing what they're suppose to.
Option Explicit
Sub CAESARCONVERSION()
Dim InputSheet As Worksheet, SummaryResults As Worksheet, Background As Worksheet
Dim i As Integer
Dim j As Integer
Dim x As Integer
Dim y As Integer
Dim h As Integer
Dim v As Integer
Dim c As Integer
Dim z As Integer
Dim myBook As Workbook
Set myBook = Excel.ThisWorkbook
Set InputSheet = myBook.Sheets("Input Sheet")
Set SummaryResults = myBook.Sheets("Summary Results")
Set Background = myBook.Sheets("Background")
Dim NodeList As Integer
Dim TotalCases As Integer
Dim sMyString As String
Dim Nodes As Variant
Dim FindRow As Range
Dim intValueToFind As String
Dim FindRowNumber As Long
Dim SecondRowNumber As Long
'Clear the last run of macro
Background.Range("A2:A1000").Cells.Clear
Background.Range("C2:I10000").Cells.Clear
SummaryResults.Cells.Clear
'Code that will count the total number of load cases
TotalCases = 0
h = 2
Dim text As String
For v = 12 To 100
If InputSheet.Cells(v, 2).Value <> "" Then
text = LTrim(InputSheet.Cells(v, 2).Value)
Background.Cells(h, 3).Value = text
h = h + 1
TotalCases = TotalCases + 1
Else
GoTo NodeCounter
End If
Next v
NodeCounter:
y = TotalCases - 1
x = 0
Dim LoadCaseList() As Variant
ReDim LoadCaseList(y)
LoadCaseList:
For x = 0 To y
LoadCaseList(x) = Background.Cells(2 + x, 3).text
Next x
j = 2
For i = 17 + TotalCases To 20000 'Need to define how far for the program to search, we may exceed 20000 at some point
If InputSheet.Cells(i, 2).Value <> "" Then
Background.Cells(j, 1).Value = InputSheet.Cells(i, 2).Value
j = j + 1
End If
Next i
With Background
NodeList = Background.Cells(2, 2).Value
Background.Range("AA1:XX" & NodeList + 1).Cells.Clear
End With
ReDim Nodes(NodeList - 1)
v = 0
j = 2
For i = 0 To NodeList - 1
Nodes(i) = Background.Cells(j, 1).Value
j = j + 1
Next i
Headers:
Dim LoadCaseHeader() As String
Dim TypHeader()
TypHeader = Array("Node", "L", "Direction", "Magnitude")
Dim LoadDirections()
LoadDirections = Array("X", "Y", "Z", "MX", "MY", "MZ")
x = 0
z = 0
For x = 0 To NodeList - 1
For z = 0 To TotalCases - 1
SummaryResults.Range(("B" & 2 + (NodeList * 6 + 2) * z) & ":" & "E" & 2 + (NodeList * 6 + 2) * z) = TypHeader()
SummaryResults.Range("A" & 2 + (NodeList * 6 + 2) * z) = Background.Range("C" & 2 + z)
Next z
Next x
'Search rows for the first instance of this value.
LoadCases:
'Code that copies information from the InputSheet to the SummaryResults
Dim LoadCases() As Long
ReDim LoadCases(NodeList, 6)
FindRowNumber = 0
SecondRowNumber = 0
For c = 0 To y
intValueToFind = LoadCaseList(c)
For i = 7 To 31 + TotalCases
With InputSheet
If Trim(Cells(i, 3).Value) = intValueToFind Then
MsgBox ("Found")
Set FindRow = InputSheet.Range("C:C").Find(What:=intValueToFind, LookIn:=xlValues)
FindRowNumber = FindRow.Row
End If
End With
Next i
'MsgBox FindRowNumber
With InputSheet
For i = 0 To NodeList - 1
x = 4
For j = 0 To 5
LoadCases(i, j) = InputSheet.Cells(FindRowNumber + (TotalCases + 3) * i, x)
x = x + 1
Next j
Next i
End With
Background.Range("AC2:AH" & NodeList + 1).Offset(0, c * 7) = LoadCases
For i = 1 To NodeList * 6 * TotalCases
With SummaryResults
If Trim(Cells(i, 5).Value) = intValueToFind Then
Set FindRow = SummaryResults.Range("A:A").Find(What:=intValueToFind, LookIn:=xlValues)
SecondRowNumber = FindRow.Row
GoTo Step2
End If
End With
Next i
Step2:
With SummaryResults
For x = 0 To NodeList - 1
For j = 0 To 5
SummaryResults.Cells(SecondRowNumber + 1 + j + 6 * x, 5) = Background.Cells(x + 2, 29 + j)
SummaryResults.Cells(SecondRowNumber + 1 + j + 6 * x, 3) = TypHeader(1)
SummaryResults.Cells(SecondRowNumber + 1 + j + 6 * x, 4) = LoadDirections(j)
SummaryResults.Cells(SecondRowNumber + 1 + j + 6 * x, 2) = Nodes(x)
Next j
Next x
End With
Next c
End Sub
Any help would be appreciated. EDIT: Uploaded the entire code. Additional information, the code works when not tabbed into excel but will fail when tabbed in a ran again.
The issue seems to be that the LoadCaseList() array is never getting populated. This is your Find statement:
Set FindRow = InputSheet.Range("C:C").Find(What:=intValueToFind, LookIn:=xlValues)
intValueToFind is set by this statement:
intValueToFind = LoadCaseList(c)
But the LoadCaseList() array is populated by the following code which is a label that is never called by a GoTo statement (as far as I can tell):
LoadCaseList:
For x = 0 To y
LoadCaseList(x) = Background.Cells(2 + x, 3).text
Next x
So because the LoadCaseList label statement is never being called by a GoTo statement, the LoadCaseList() array is never being populated so intValueToFind has no value and therefore the Find method has no value to search for (except for maybe the empty string).