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).
Related
I am trying to figure out a loop logic to get all possible permutations where I add a set value to each item in a set array iLoop number of times. I'm gonna try my best to explain what I am looking for.
I have a set value "StrokeValue" and a set array "DistanceMatesArray"
Dim StrokeValue as single
Dim DistanceMatesArray as variant
StrokeValue = 300
DistanceMatesArray = Array(300, 300, 300, 300)
Now I need to loop through each possible result where I add StrokeValue to each Item which in the first loop would result in possible DistanceMatesArrays:
The tricky part is when I want to add StrokeValue more than once and get every outcome where I added StrokeValue iLoop number of time "AllowedActions" resulting in a list such as:
I kind of suspect that I need a 2D array to store all the results from previous loop., that's why in the example the rows are coloured to indicate which one row was taken as a starting point to add the StrokeValue once
What I got so far looks like this:
Public StrokeValue As Single
Public DistanceMatesArray As Variant
Public iError As Long
Public NumberOfCombinations As Long
Public x As Long
Public y As Long
Public i As Long
Option Explicit
Sub Test()
'Declare variables
Dim PreviousLoopResultsArray As Variant
Dim NextLoopResultsArray As Variant
Dim iresults As Long
Dim iLoop As Long
Dim iPreviousResult As Long
'Set variables
StrokeValue = 300
'Array
DistanceMatesArray = Array(300, 300, 300, 300)
ReDim NextLoopResultsArray(0, UBound(DistanceMatesArray))
For i = LBound(DistanceMatesArray) To UBound(DistanceMatesArray)
NextLoopResultsArray(0, i) = DistanceMatesArray(i)
Next i
'------------------------------------------------------
'Loop
Do While iError = NumberOfCombinations
'Try DistanceMatesArray
For i = 0 To iresults
For x = 0 To UBound(DistanceMatesArray) 'Loop horizontally
DistanceMatesArray(x) = NextLoopResultsArray(i, x)
Next x
Debug.Print Join(DistanceMatesArray)
'TRY HERE
Next i
'Array
PreviousLoopResultsArray = NextLoopResultsArray
'Array
If iLoop <> 0 Then
For x = 0 To UBound(DistanceMatesArray) 'Loop horizontally
DistanceMatesArray(x) = PreviousLoopResultsArray(iPreviousResult, x)
Next x
End If
'Set variables
iLoop = iLoop + 1
iPreviousResult = 1
iresults = ((UBound(DistanceMatesArray) + 1) ^ iLoop) - 1
ReDim NextLoopResultsArray(iresults, UBound(DistanceMatesArray))
'Populate NextLoopResultsArray
For y = 0 To iresults 'Loop vertically
If y Mod (UBound(DistanceMatesArray) + 1) = 0 And y <> iresults And y <> 0 Then
For x = 0 To UBound(DistanceMatesArray) 'Loop horizontally
DistanceMatesArray(x) = PreviousLoopResultsArray(iPreviousResult, x)
Next x
iPreviousResult = iPreviousResult + 1
End If
For x = 0 To UBound(DistanceMatesArray) 'Loop horizontally
NextLoopResultsArray(y, x) = DistanceMatesArray(x)
With ThisWorkbook.Worksheets(1).Cells(y + 1, x + 1)
.Value = NextLoopResultsArray(y, x)
End With
Next x
Next y
'Modify NextLoopResultsArray
x = 0
For y = 0 To iresults 'Loop vertically
NextLoopResultsArray(y, x) = NextLoopResultsArray(y, x) + StrokeValue
With ThisWorkbook.Worksheets(1).Cells(y + 1, x + 1)
.Value = NextLoopResultsArray(y, x)
.Interior.Color = vbYellow
End With
If x + 1 > UBound(DistanceMatesArray) Then
x = 0
Else
x = x + 1
End If
Next y
'Set variables
iPreviousResult = 0
'Excel reset
For i = 1 To (UBound(DistanceMatesArray) + 1)
Columns(i).Clear
Next i
Loop
End Sub
At the end of the loop I am expecting to have each one row as DistanceMatesArray i.e. one of them would now be
DistanceMatesArray = array(300,600,600,300)
Where it added StrokeValue twice.
Would someone, please, help me figure out a shorter and simpler logic behind this?
EDIT:
Results expected after running it up to 3 loops looks like this:
And without duplicate outcomes
Continuing to try and figure out the logic of it, maybe now someone get's a betetr idea for what I am lookign for and can help
No need to mention that it's an infinite loop - I know that and That's the point, it needs to go on untill I validate the right array in which case iError <> NumberOfCombinations.
Been able to learn more about arrays, so I consider this a big win.
The code took in account the duplicates but for now your iterations are hardset (could easily ask how many iterations with an inputbox), not in the endless loop you had set up, hope that rework won't be too much.
Some variables are reworked, I tried to keep most of your original ones though.
Public StrokeValue As Single
Public DistanceMatesArray As Variant
Public iError As Long
Public iTerations As Long
Public i As Long
Public j As Long
Public k As Long
Option Explicit
Sub TestArrayfill()
Dim pArray As Variant, nArray As Variant, cArray As Variant 'pArray = previous array, nArray = next array, cArray = check array
Dim iresults As Long, iLoop As Long, nb As Long, actB As Long, addCounter As Long, Lastrow As Long
'Set variables
StrokeValue = 300
addCounter = 1
iTerations = 4
'Array
DistanceMatesArray = Array(300, 300, 300, 300)
nb = UBound(DistanceMatesArray) + 1
ReDim Preserve DistanceMatesArray(1 To nb)
cArray = DistanceMatesArray
ReDim pArray(1 To nb, 1 To nb)
For i = 1 To nb
pArray(1, i) = DistanceMatesArray(i)
Next i
actB = nb
For iLoop = 1 To iTerations 'I can't figure out the limitations with permutations so we'll just bruteforce it with nb*actB (maximum possibilities)
ReDim nArray(1 To nb * actB, 1 To nb) '(re)setting nArray
If iLoop = 1 Then actB = 1 'workaround to have pArray as a 2D-array
For i = 1 To actB 'loop through every row in pArray except for when iLoop = 1
For j = 1 To nb 'loop through every cell in pArray(i)
For k = 1 To nb 'setting the extra StrokeValue
If j = k Then
cArray(k) = pArray(i, k) + StrokeValue
Else
cArray(k) = pArray(i, k)
End If
Next k
If Not arrElemInArray(cArray, nArray) Then
For k = 1 To nb
nArray(addCounter, k) = cArray(k) 'add the "row" to our nArray
Next k
addCounter = addCounter + 1
End If
Next j
Next i
actB = addCounter - 1
ReDim pArray(1 To actB, 1 To nb) 'ReDim is possible on both dimensions, Redim Preserve is not so we use this to our advantage
For i = 1 To actB 'another loop is necessary however
For j = 1 To nb
pArray(i, j) = nArray(i, j)
Next j
Next i
' nArray = Application.Transpose(nArray)
' ReDim Preserve nArray(1 To nb, 1 To actB)
' nArray = Application.Transpose(nArray)
' pArray = Application.Transpose(pArray)
' ReDim pArray(1 To UBound(nArray, 2), UBound(nArray, 1))
' pArray = Application.Transpose(pArray)
' pArray = nArray
addCounter = 1
Lastrow = Range("A" & Rows.Count).End(xlUp).Row
If Lastrow = 1 Then
Cells(Lastrow, 1).Value = "Loop" & iLoop
Else
Cells(Lastrow + 1, 1).Value = "Loop " & iLoop
Lastrow = Lastrow + 1
End If
Cells(Lastrow + 1, 1).Resize(UBound(nArray, 1), UBound(nArray, 2)) = nArray
Next iLoop
End Sub
Function arrElemInArray(arr As Variant, arrX As Variant) As Boolean 'this is from one of your previous questions btw, just a bit modified to fit our needs
Dim i As Long, j As Long, boolFound As Boolean, mtch
If Not IsArray(arrX) Then
For j = LBound(arr) To UBound(arr)
If arr(j) = arrX Then arrElemInArray = True: Exit For
Next j
Exit Function
End If
For i = LBound(arrX) To UBound(arrX)
boolFound = True 'True at beginning so if any cells deviates from the corresponding check, it gets set to False, ergo it doesn't exist yet.
For j = LBound(arr) To UBound(arr)
If arr(j) <> arrX(i, j) Then
boolFound = False
End If
Next j
If boolFound Then arrElemInArray = True: Exit Function
Next i
arrElemInArray = False
End Function
Hope it's all clear and works for you :)
I understood your logic for the first table
but for the following ones I find it difficult to understand what you want especially in relation to the capture that you put in your message
for the first
Sub testing()
Dim StrokeValue As Single
Dim DistanceMatesArray As Variant
Dim i As Long 'variable row iteration
Dim c As Long 'variable column itération
Dim Table As Variant 'variable variant no dimention in the first
StrokeValue = 300
DistanceMatesArray = Array(300, 300, 300, 300) 'is an array in base 0
nb = UBound(DistanceMatesArray) + 1 'convert a ubound of DistanceMatesArray in count (in base 1)
ReDim Table(1 To nb, 1 To nb) 'table dimensioning (variant) in base 1
'loop for row
For i = 1 To UBound(Table) 'start at index 1
'loop for column
For c = 1 To UBound(Table, 2) 'start at index 1
'if index row and index column then item has multipled by (2)
If c <> i Then Table(i, c) = StrokeValue Else Table(i, c) = StrokeValue + StrokeValue
Next c
Next i
'just for see on sheet
Cells.Resize(UBound(Table), UBound(Table)) = Table
End Sub
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 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.
I have already looked at a few examples of how to use Application.OnTime,
to check for progress within the cell before updating and wrote up an implementation but I'm not sure why it wont work.
I dont want to paste the whole thing here, because it may be more confusing than just looking at the subs within the workbook.
I was wondering if someone with experience with this type of thing would be willing to look at my code. I can pm the file I'm working on.
Here is the method that loads data into the shell sheet. Ideally the data will all load before the pattern_recogADR sub is run... otherwise there is an error.
Sub build_singleEquity()
'x As Long
Dim x As Long
x = 6
'Dim x As Long
'x = 4
Application.ScreenUpdating = False
Call DefineTixCollection 'creates table of inputs
'check
'Debug.Print TixCollection(4).ORD
'set up data points - from "Input" sheet
'Dim x As Long
'Dim path As String
'path = Sheets("Input").Range("V1").value
'For x = 1 To TixCollection.Count
Sheets("SingleEquityHistoryHedge").Activate
'clear inputs
Range("B2:B8").Clear
Dim Inputs() As Variant
Dim name As String
name = "SingleEquityHistoryHedge"
'insert new inputs
Inputs = Array(TixCollection(x).ADR, TixCollection(x).ORD, TixCollection(x).ratio, _
TixCollection(x).crrncy, TixCollection(x).hedge_index, TixCollection(x).hedge_ord, _
TixCollection(x).hedge_ratio)
Call PrintArray(2, 2, Inputs, name, "yes") ' prints inputs
Dim last_row As Long
last_row = Range("A" & Rows.count).End(xlUp).Row
Range("AN11") = "USD" & TixCollection(x).crrncy
Range("AA11") = "USD" & TixCollection(x).crrncy
' Dim sht_name As String
'Application.Run "RefreshAllStaticData"
BloombergUI.ThisWorkbook.RefreshAll
' sht_name = TixCollection(x).ADR
' Call Sheet_SaveAs(path, sht_name, "SingleEquityHistoryHedge") 'save collection of sheets
'Next x
'Call TriggerCalc
'check this out
Call pattern_recogADR(x + 4, 5, 13)
End Sub
Here is the pattern_recogADR sub.... as you can see I have tried a ton of different thing which are commented out.
Sub pattern_recogADR(pos As Long, pat_days As Long, sht_start As Long)
'
'Application.Wait Now + "00:00:20"
'Dim pat As pattern
'Dim tix As clsTix
Dim newTime As Date
newTime = Now + TimeValue("00:00:30")
Do While Not Now >= newTime
'add back in as parameters
'Dim pos As Long
Dim x As Long
'Dim pat_days As Long
'Dim sht_start As Long
'************************
'pos = 5
'pat_days = 5
'sht_start = 13
Sheets("SingleEquityHistoryHedge").Activate
'Sleep 20000 'sleeps
Dim st As Long
Dim st_num As Long
Dim st_end As Long
Dim count As Long
Dim patrn As Long
count = sht_start
Dim i As Long
Dim j As Long
Dim patPLUSret() As Variant
Dim k As Long
Dim z As Long
k = 2
z = 3
For j = 8 To 12
'**************************************
count = sht_start
st_num = sht_start
st_end = 13
If IsNumeric(Cells(count, j).value) Then
'sets default pattern to beginning cell value
' Debug.Print st_num
If Cells(st_num, j).value < 0 Then
For i = count + 1 To count + 1 + pat_days
If IsNumeric(Cells(i, j).value) Then
If Cells(i, j).value < 0 Then
st_end = i
'Debug.Print st_end
End If
Else
Exit For
End If
Next i
patrn = st_end - st_num
' Debug.Print count
' Debug.Print patrn
ReDim Preserve patPLUSret(k * 2 + 1)
patPLUSret(0) = Range("B2").value 'ADR
patPLUSret(1) = Range("B3").value 'ORD
patPLUSret(k) = patrn
patPLUSret(z) = Application.WorksheetFunction.Average(Range(Cells(st_num, j), Cells(st_end, j)))
' Debug.Print patPLUSret(j)
' Debug.Print patPLUSret(j + 1)
st_num = sht_start 'resets starting point to initial
st_end = sht_start
' For x = 4 To 6
' If Range("L" & x).value = "x" Then
' ReDim Preserve mac_array(x - 4)
' mac_array(x - 4) = Range("N" & x).value
' End If
' Next x
' check this out
'tix.arbPnl = patrn
'save to separate class for patterns
'TixCollection.Add tix, tix.ADR
'******************************
ElseIf Cells(st_num, j).value > 0 Then
For i = count + 1 To count + 1 + pat_days
If IsNumeric(Cells(i, j).value) Then
If Cells(i, j).value > 0 Then
st_end = i
End If
Else
st_end = st_num
Exit For
End If
Next i
patrn = st_end - st_num
ReDim Preserve patPLUSret(k * 2 + 1)
patPLUSret(0) = Range("B2").value 'ADR
patPLUSret(1) = Range("B3").value 'ORD
patPLUSret(k) = patrn
patPLUSret(z) = Application.WorksheetFunction.Average(Range(Cells(st_num, j), Cells(st_end, j)))
' Debug.Print patPLUSret(j)
' Debug.Print patPLUSret(j + 1)
st_num = sht_start 'resets starting point to initial
st_end = sht_start
' Debug.Print patrn
'pat.arbPnl = patrn
'save to separate class for patterns
End If
k = k + 2
z = z + 2
Else
count = count + 1
st_num = count
End If
'
' k = k + 1
'new_array = patPLUSret
Next j
' Debug.Print patPLUSret
Sheets("PatternADR_ORD").Activate
Range(Cells(pos, 1), Cells(pos, 10)) = patPLUSret
Loop
End Sub
If you wait or loop to simulate a wait in your second sub, it won't give the control back to the spreadsheet and your formulae won't update.
Instead of
Call pattern_recogADR(x + 4, 5, 13)
why don't you call:
Application.onTime "'pattern_recogADR ""x + 4"", ""5"", ""13""'"