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.
Related
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
I have 2 excel sheets and i have to compare some values,this is the easy part. For this i used the following code :
Dim OldLabel() As String, size As Integer, i As Integer, j As Integer
size = WorksheetFunction.CountA(Worksheets(3).Columns(1))
ReDim OldLabel(size)
j = 1
For i = 7 To size
If (InStr(Cells(i, 1).Value, "[") > 0) Then
OldLabel(j) = Cells(i, 1).Value
j = j + 1
End If
Next i
Dim NewLabel() As String, newSize As Integer, k As Integer, l As Integer
newSize = WorksheetFunction.CountA(Worksheets(4).Columns(1))
ReDim NewLabel(newSize)
l = 1
For k = 7 To newSize
If (InStr(Cells(k, 1).Value, "[") > 0) Then
NewLabel(l) = Cells(k, 1).Value
l = l + 1
End If
Next k
After that i have to compare the values of the two arrays and check if they are the same and write them to another sheet. I have tried to following code but it doesn't seem to be working.
Dim cont As Integer
cont = 1
For i = 1 To size
For k = 1 To newSize
If (OldLabel(i) = NewLabel(k)) Then
Sheet8.Activate
Range("A1").Select
Cells(cont, 1).Value = OldLabel(i)
cont = cont + 1
End If
Next k
Next i
This is one of the cases I recommend the use of data collections instead of arrays:
'Define data collections:
Dim OldLabel As New Collection: Set OldLabel = New Collection
Dim NewLabel As New Collection: Set NewLabel = New Collection
'Define data limits:
Dim OldLimit As Integer
OldLimit = ThisWorkbook.Sheets("Sheet3").Columns(1).Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row
Dim NewLimit As Integer
NewLimit = ThisWorkbook.Sheets("Sheet4").Columns(1).Find("*", SearchOrder:=xlByRows, LookIn:=xlValues, SearchDirection:=xlPrevious).Row
'Define extra variables:
Dim counter As Integer
counter = 1
'Fill collections:
For x = 1 To OldLimit
If InStr(ThisWorkbook.Sheets("Sheet3").Cells(x, 1).text, "[") > 0 Then
OldLabel.Add ThisWorkbook.Sheets("Sheet3").Cells(x, 1).text
End If
Next x
For x = 1 To NewLimit
If InStr(ThisWorkbook.Sheets("Sheet4").Cells(x, 1).text, "[") > 0 Then
NewLabel.Add ThisWorkbook.Sheets("Sheet4").Cells(x, 1).text
End If
Next x
'Writer:
If OldLabel.Count > 0 And NewLabel.Count > 0 Then
For x = 1 To OldLabel.Count
For y = 1 To NewLabel.Count
If OldLabel(x) = NewLabel(y) Then
ThisWorkbook.Sheets("Sheet8").Cells(counter, 1).FormulaR1C1 = OldLabel(x)
counter = counter + 1
End If
Next y
Next x
End If
Please note: a) You don't have to activate worksheets for your procedure; b) I named the worksheets and used that name to reference them; for some reasons, I prefer don't use sheets indexes; c) Check the fact you're only comparing cells with the "[" character in them; d) If any of the data columns is empty, the code will produce an error.
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).
I was wondering why the following syntax does not work the way I thought it would in VBA, and what I should do to ensure it does;
For a = 1 To 10
For b = 1 To 10
For c = 1 To 10
If a <> b <> c Then
MsgBox (a & " " & b & " " & c)
End If
Next c
Next b
Next a
This is a simplified example, which can still be manually obtained with:
if a<>b and b<>c and c<>a then
But my actual intended code has 10 such variables multiple times, which makes it unfeasible with 55 unequal conditions, or likely for me to make a typo. I think there is a more efficient way but I have not found it.
Ps. My goal is to only have a message box pop up if all the variables are unique.
I have obtained my goal, though it can probably be done much more efficient than:
For a = 1 To 10
check(a) = True
For b = 1 To 10
If check(b) = False Then
check(b) = True
For c = 1 To 10
If check(c) = False Then
check(c) = True
For d = 1 To 10
If check(d) = False Then
check(d) = True
For e = 1 To 10
If check(e) = False Then
check(e) = True
MsgBox (a & " " & b & " " & c & " " & d & " " & e)
End If
check(e) = False
check(a) = True
check(b) = True
check(c) = True
check(d) = True
Next e
End If
check(d) = False
check(a) = True
check(b) = True
check(c) = True
Next d
End If
check(c) = False
check(a) = True
check(b) = True
Next c
End If
check(b) = False
check(a) = True
Next b
Next a
Here is an implementation of the Johnson-Trotter algorithm for enumerating permutations. It is a small modification of one that I wrote once when playing around with brute-force solutions to the Traveling Salesman Problem. Note that it returns a 2-dimensional array, which might consume a lot of memory. It is possible to refactor it so that it is a sub where the permutations are consumed rather than stored. Just replace the part of the code near the bottom (where the current permutation, perm, is stored in the array perms) by the code that uses the permutation.
Function Permutations(n As Long) As Variant
'implements Johnson-Trotter algorithm for
'listing permutations. Returns results as a variant array
'Thus not feasible for n > 10 or so
Dim perm As Variant, perms As Variant
Dim i As Long, j As Long, k As Long, r As Long, D As Long, m As Long
Dim p_i As Long, p_j As Long
Dim state As Variant
m = Application.WorksheetFunction.Fact(n)
ReDim perm(1 To n)
ReDim perms(1 To m, 1 To n) As Integer
ReDim state(1 To n, 1 To 2) 'state(i,1) = where item i is currently in perm
'state(i,2) = direction of i
k = 1 'will point to current permutation
For i = 1 To n
perm(i) = i
perms(k, i) = i
state(i, 1) = i
state(i, 2) = -1
Next i
state(1, 2) = 0
i = n 'from here on out, i will denote the largest moving
'will be 0 at the end
Do While i > 0
D = state(i, 2)
'swap
p_i = state(i, 1)
p_j = p_i + D
j = perm(p_j)
perm(p_i) = j
state(i, 1) = p_j
perm(p_j) = i
state(j, 1) = p_i
p_i = p_j
If p_i = 1 Or p_i = n Then
state(i, 2) = 0
Else
p_j = p_i + D
If perm(p_j) > i Then state(i, 2) = 0
End If
For j = i + 1 To n
If state(j, 1) < p_i Then
state(j, 2) = 1
Else
state(j, 2) = -1
End If
Next j
'now find i for next pass through loop
If i < n Then
i = n
Else
i = 0
For j = 1 To n
If state(j, 2) <> 0 And j > i Then i = j
Next j
End If
'record perm in perms:
k = k + 1
For r = 1 To n
perms(k, r) = perm(r)
Next r
Loop
Permutations = perms
End Function
Tested like:
Sub test()
Range("A1:G5040").Value = Permutations(7)
Dim A As Variant, i As Long, s As String
A = Permutations(10)
For i = 1 To 10
s = s & " " & A(3628800, i)
Next i
Debug.Print s
End Sub
The first 20 rows of output look like:
Also, 2 1 3 4 5 6 7 8 9 10 is printed in the immediate window. My first version used a vanilla variant away and caused an out-of-memory error with n = 10. I tweaked it so that perms is redimensioned to contain integers (which consume less memory than variants) and is now able to handle 10. It takes about 10 seconds on my machine to run the test code.
You could simply add a check right after the beginning of each inner loop, like follows
For a = 1 To 10
For b = 1 To 10
If b <> a Then '<-- this check will make sure subsequent inner loops shouldn't bother but for their loops variables
For c = 1 To 10
If c <> b Then '<-- same comment as preceeding one
For d = 1 to 10
If d <> c then MsgBox (a & " " & b & " " & c & " " & d) '<-- last check for last two variables
Next d
End If
Next c
End If
Next b
Next a
Try putting all those variables into the array and checking the array for duplicates, if none found, display the message box. Something like this:
Sub dupfind()
Dim ArrHelper(2) As Long
Dim k As Long
Dim j As Long
Dim ans As Long
Dim dupl As Boolean
Dim ArrAnswers() As Long
ans = 0
For a = 1 To 10
ArrHelper(0) = a
For b = 2 To 10
ArrHelper(1) = b
For c = 1 To 10
ArrHelper(2) = c
dupl = False
For k = 0 To UBound(ArrHelper) - 1
For j = k + 1 To UBound(ArrHelper)
If ArrHelper(k) = ArrHelper(j) Then
dupl = True
End If
Next j
Next k
If dupl = False Then
ReDim Preserve ArrAnswers(3, ans)
ArrAnswers(0, ans) = a
ArrAnswers(1, ans) = b
ArrAnswers(2, ans) = c
ans = ans + 1
End If
Next c
Next b
Next a
End Sub
Read your edit regarding storing permutations and changed the code a bit
I am working on a project that includes multiples Excel files with cells containing English, Chinese, or both English and Chinese.
I need to keep the rows that are completely in Chinese and put them first. Then, I need lines with both Chinese characters and English. And only then those that are in English only.
I came across the following 3 functions that could help me mark the content accordingly, yet they do not seem to be working as expected, and I cannot figure out why.
Function ExtractChn(txt As String)
Dim i As Integer
Dim ChnTxt As String
For i = 1 To Len(txt)
If Asc(Mid(txt, i, 1)) < 0 Then
ChnTxt = ChnTxt & Mid(txt, i, 1)
End If
Next i
ExtractChn = ChnTxt
End Function
Function ExtractEng(txt As String)
Dim i As Integer
Dim EngTxt As String
For i = 1 To Len(txt)
If Asc(Mid(txt, i, 1)) >= 0 Then
EngTxt = EngTxt & Mid(txt, i, 1)
End If
Next i
ExtractEng = EngTxt
End Function
Function CheckTxt(txt)
Dim i As Integer
Dim Eng As Integer
Dim Chn As Integer
Chn = 0
Eng = 0
For i = 1 To Len(txt)
If Asc(Mid(txt, i, 1)) > 0 Then
Eng = 1
Else:
Chn = 1
End If
Next i
If Chn = 1 And Eng = 1 Then 'Contains Both Eng & Chn
CheckTxt = "BOTH"
Else:
If Chn = 1 And Eng = 0 Then 'Chn
CheckTxt = "CHN"
Else:
If Chn = 0 And Eng = 1 Then 'Eng
CheckTxt = "ENG"
End If
End If
End If
End Function
The person who created them even supplied a file demonstrating how the functions work. I am attaching the link to the file which has the arrangement as follows:
Text|English part of it|Chinese part of it|ExtractEng|ExtractChn|CheckTxt
According to the author's intentions, the CheckTxt result should display either CH, ENG, or BOTH. However, it is only displaying ENG at all times and I cannot figure why.
Any ideas how to make it work? Unless there is an easier way to 'advance-filter' the content in Excel? Any help will be much appreciated.
Test Excel file from the developer
This sounds like a job for Regular Expressions!!
Function getCharSet(Target As Range) As String
Const ChinesePattern = "[\u4E00-\u9FFF\u6300-\u77FF\u7800-\u8CFF\u8D00-\u9FFF]+"
Const EnglishPattern = "[A-Za-z]"
Dim results As String
Dim Data, v
Dim Regex1 As Object
Set Regex1 = CreateObject("VBScript.RegExp")
Regex1.Global = True
If Target.Count = 1 Then
Data = Array(Target.Value2)
Else
Data = Target.Value2
End If
For Each v In Data
If Not InStr(results, "CHN") Then
Regex1.Pattern = ChinesePattern
If Regex1.Test(v) Then
If Len(results) Then
getCharSet = "CHN" & " - " & results
Exit Function
Else
results = "CHN"
End If
End If
End If
If Not InStr(results, "ENG") Then
Regex1.Pattern = EnglishPattern
If Regex1.Test(v) Then
If Len(results) Then
getCharSet = results & " - ENG"
Exit Function
Else
results = "ENG"
End If
End If
End If
Next
getCharSet = results
End Function
A basic approach :
Sub Main()
Dim sh As Worksheet
Set sh = ActiveSheet
Dim rng As Range
Set rng = sh.Range("A6:D10")
Call Separate_English_Chinese(rng)
End Sub
Sub Separate_English_Chinese(rng)
Dim sh As Worksheet
Set sh = rng.Parent
Dim EnglishCharacters As String
Dim colEng As Long, colChn As Long, colContains As Long
Dim a As String, i As Long, k As Long
Dim colFullText As Long, txtEnglish As String, txtChinese As String
Dim Result As Long, Contains As String
Dim First As Long, Last As Long
First = rng.Row
Last = rng.Rows.Count + rng.Row - 1
EnglishCharacters = "qwertyuiopasdfghjklzxcvbnm"
EnglishCharacters = UCase(EnglishCharacters) & LCase(EnglishCharacters)
colFullText = 1
colEng = 2
colChn = 3
colContains = 4
For i = First To Last
a = sh.Cells(i, colFullText).Value
txtEnglish = ""
txtChinese = ""
For k = 1 To Len(a)
If InStr(EnglishCharacters, Mid(a, k, 1)) Then
txtEnglish = txtEnglish & Mid(a, k, 1)
Else
txtChinese = txtChinese & Mid(a, k, 1)
End If
Next
sh.Cells(i, colEng).Value = txtEnglish
sh.Cells(i, colChn).Value = txtChinese
Result = 0
If txtEnglish <> "" Then Result = Result + 1
If txtChinese <> "" Then Result = Result + 10
Select Case Result
Case 1
Contains = "ENG"
Case 10
Contains = "CHN"
Case 11
Contains = "BOTH"
Case Else
Contains = ""
End Select
sh.Cells(i, colContains).Value = Contains
Next
End Sub