I am using split function and assigning the value in a variable and running the code in loop after few iterations its giving an error of "This array is fixed or temporarily locked (Visual Basic)"..
e.g; here value of movies_cat1 read from excel is in form of this------
"Movies->List All Movies , Movies->World Cinema->Asia , Movies->Movies by Language->Sinhalese , Movies->Drama"
For crow = 1 To 100
Value = Worksheets("Movies_categories").Range("A" & crow).Value
cat_final = Worksheets("Movies_categories").Range("B" & crow).Value
If Value = "y" Or Value = "Y" Then
'Loop for reading the data from tabsheet- Movies
For crowss = 5 To 3000
movies_cat1 = Worksheets("Movies").Range("B" & crowss).Value
movies_language = Worksheets("Movies").Range("C" & crowss).Value
If movies_language = "English" Then
Temp = Split(movies_cat, ",") 'run time Error:10 occurs here..
For Each boken_c In Temp
flag = 0
boken_c = Trim(boken_c)
If RTrim(LTrim(boken_c)) = LTrim(RTrim(cat_final)) Then
flag = 1
GoTo Line4:
End If
Next boken_c
End If
Next crowss
End If
Line4: Next crow
Error occurs at this statement: Temp = Split(movies_cat, ","), it says that the array is fixed or temporarily locked, because i think initially its taking 'temp' as a variable, but while returning the value of split function, variable 'Temp' becomes array after completion of first loop(i.e after crow = 6,7....)
Your line4 label is outside the for loop on the temp variable so when you goto it leaves it locked.
You really should restructure your code to not use a goto inside the for each loop.
Maybe:
For crow = 1 To 100
Value = Worksheets("Movies_categories").Range("A" & crow).Value
cat_final = Worksheets("Movies_categories").Range("B" & crow).Value
If Value = "y" Or Value = "Y" Then
'Loop for reading the data from tabsheet- Movies
For crowss = 5 To 3000
movies_cat1 = Worksheets("Movies").Range("B" & crowss).Value
movies_language = Worksheets("Movies").Range("C" & crowss).Value
If movies_language = "English" Then
Temp = Split(movies_cat, ",") 'run time Error:10 occurs here..
For Each boken_c In Temp
flag = 0
boken_c = Trim(boken_c)
If RTrim(LTrim(boken_c)) = LTrim(RTrim(cat_final)) Then
flag = 1
**Exit For**
End If
**If flag = 1 Then Exit For**
Next boken_c
End If
**If flag = 1 Then Exit For**
Next crowss
End If
Next crow
(Note the **d lines.)
I had this problem too with VBA. I cannot say I am proud of how I managed to get it, but it is supplied here just in can anyone else accidentally slips up on this.
It is quite interesting to debug as the failure occurs at the call to a sub or function - not at the point of failure. Luckily, you can follow the code through to the offending line of the called routine before it reports the error.
Call Sub1(gArray(3))
debug.print gArray(3)
...
Sub Sub1(i as integer)
Redim gArray(0)
End sub
Clearly the VB RT is not going to like this as by the time the debug.print executes, the array dimension does not exist. Ok why the hell would you want to pass a globally declared array anyway? Guilty as charged.
So in the example above you get the error at the call to Sub1, but the thing causing it is the Redim in the sub.
The moral to the story is do not pass global variables as parameters to subs. Another simple fix is to declare the Sub1 slightly differently:
Sub Sub1(ByVal i as integer)
This means the i variable is copied (but not returned) by the Sub.
Thanks, Deanna for the answer! I have a similar message on ReDim Preserve statement at the last line in next fragment of code:
If StrComp(Mid(s, 1, lE), txtE, vbBinaryCompare) = 0 Then
For i = iMdl To 1 Step -1
With blks(i)
If .lnEnd = 0 Then ' ".lnEnd" is a member of blks(i)
.lnEnd = ln
GoTo NXT
End If
End With
Next
errBegWith = errBegWith & ln & ", "
NXT:
End If
'...
ReDim Preserve blks(iMdl)
And after extracting assignment .lnEnd = ln from inside of the With the program works fine:
If StrComp(Mid(s, 1, lE), txtE, vbBinaryCompare) = 0 Then
For i = iMdl To 1 Step -1
If blks(i).lnEnd = 0 Then
blks(i).lnEnd = ln
GoTo NXT
End If
Next
errBegWith = errBegWith & ln & ", "
NXT:
End If
'...
ReDim Preserve blks(iMdl)
Related
I've got a strange problem with a loop in VBA, as it seems to be losing the value of my variable. Any ideas why? If i delete the loop, debug.print shows "test", otherwise it's empty (unless I print the value of "dupa" inside the loop)... Seems very strange.
Function carbon_copy(indeks As String) As String
Dim emails(1 To 3) As String
Dim i As Integer
Dim dupa As String
emails(1) = "abc#wp.pl"
emails(2) = "pabc#wp.pl"
emails(3) = "rabc#wp.pl"
i = 1
dupa = "test"
Do While emails(i) <> ""
If i = indeks Then
GoTo NextIteration
End If
dupa = dupa & ";" & emails(i)
NextIteration:
i = i + 1
Loop
Debug.Print dupa
carbon_copy = dupa
End Function
You should get a runtime error 9 since you index i will be 4 after you looped through your emails String array. As soon as it tries to compare the value of emails(4) with "" it should produce the "index out of range" since you have defined your Array to be only 3 elements long.
For a little clarification try this example code, it should produce the same error:
Function littleTest()
Dim teststr(1 To 3) As String
Dim i As Integer
teststr(1) = "abc"
teststr(2) = "def"
teststr(3) = "ghi"
i = 1
Do While teststr(i) <> ""
Debug.Print "i do it for the " & i & " time!"
i = i + 1
Loop
End Function
You have already found the solution yourself since UBound() is returning the actual length of your array which is in your case three so it will never search beyond the array.
You're indexing out of the array bounds. The condition Do While emails(i) <> "" is always true given your array, so the this fails on emails(4). Just test the array bounds and loop over that:
For i = LBound(emails) To UBound(emails)
If emails(i) <> "" And i = indeks Then
dupa = dupa & ";" & emails(i)
End If
Next
Actually, I've already solved the problem by using other loop type (For i = 1 To UBound(emails), Next i), but why the previous loop did not work is still quite mysterious to me... If anyone can explain, I'd appreciate it, as I prefer to understand things rather thank just do them correctly.
W.
this should work (explanations in comments):
Function carbon_copy(indeks As Long) As String
Dim emails(1 To 3) As String
Dim i As Long
Dim dupa As String
emails(1) = "abc#wp.pl"
emails(2) = "pabc#wp.pl"
emails(3) = "rabc#wp.pl"
i = 1
Do While emails(i) <> ""
If i <> indeks Then dupa = dupa & ";" & emails(i) ' update 'dupa' if current index doesn't natch passed 'indeks'
i = i + 1
If i > UBound(emails, 1) Then Exit Do ' be sure to exit upon exceeding 'emails()' array size
Loop
carbon_copy = dupa
End Function
I've got a really odd case… hopefully someone is able to help me out, I've search many forums looking for a solution, the closest I could find related to it (kinda) is here, though I've tried all the suggestions to no avail…
I'm trying to run a function to return a data list in a string delimitated by a semicolon from an oracle stored function. (This value function call seems to work fine).
I then loop through the string for each data value and print it to a blank table (0 rows) declared in my subroutine. which I use to load into an access data base. (just trust it make sense in the big picture…).
The issue, fundamentally is that no information is printed into the table. However when I step through the code it works fine.
After troubleshooting I THINK (see my test scenarios below code) the issue comes up after the listrows.add line... though not obviously.
I don't think this line is executed by the time the first value is trying to print to the table.
The most confusing part is I'm running through 2 nearly identical procedures (call function -> Return value -> print values to table) immediately before this portion of the code and they work without fail.
Code Excerpt:
'run function to get string ... this works
DoEvents ' not in original design
RelRtnStr = Prnt(Cat, "A Third Oracle Function Name")
DoEvents ' not in original design
RelChopVar = RelRtnStr
StrFldCnt = 0
Checking = True ''' CodeBreak Test 1
DoEvents ' not in original design
AppendRlLmTbl.ListRows.Add ''''''''This isn't appearing to work...
DoEvents ' not in original design
Debug.Print Now ' not in original design
Application.Wait (Now + TimeValue("0:00:3")) ' not in original design
Debug.Print Now ' not in original design
While StrFldCnt < 80 And (Len(RelChopVar) - Len(Replace(RelChopVar, ";", ""))) > 0 And Checking
'## Count String Position
StrFldCnt = StrFldCnt + 1
'## Find Current String Value & Remainder String
If InStr(RelChopVar, ";") <> 0 Then
'Multiple Values Left
FldVal = Replace(Left(RelChopVar, InStr(RelChopVar, ";")), ";", "")
RelChopVar = Right(RelChopVar, Len(RelChopVar) - InStr(RelChopVar, ";"))
Else
'Last Value
FldVal = RelChopVar
Checking = False
End If
'## Get Field Name For Current Value & Print to Table
FldNm = CStr(RefRtrn(2, CStr(StrFldCnt))) ''' CodeBreak Test 2
AppendRlLmTbl.ListColumns(FldNm).DataBodyRange.Value = FldVal '''CodeBreak 2 error thrown
Debug.Print StrFldCnt & FldNm & FldVal
Wend
AppendRlLmTbl.ListColumns("Catalogue").DataBodyRange.Value = Cat
So far I've tested a ton of options suggested online, not necessarily understanding each test... This is what I've gleaned.
If I step through the code, it works
If I set a breakpoint at "CodeBreak Test 1" and "F5" the rest, it works …
If I set a breakpoint at "CodeBreak Test 2" I get an "Object with variable not set" error thrown …
Things I've tried …
Wrapping anything and everything with DoEvents
setting a wait time after the listObjects.add row
Validated the code performs the While loop when running the "full procured" (as opposed to stepping through)
The worst part, I have no idea why the object won't declare properly when setting a break point after the add row line but sets properly when break point is set before and has no error thrown when running the full procedure (I have no on error declarations.)...
It of course must be related in my mind but I can't find any information online and unfortunately have no formal VBA background and 1 undergrad course as a programming background in general. Aka I'm out of my depth and super frustrated.
PS. first post, so please be nice :p
Full Code Below:
Option Explicit
'## Here's my attempt to clean up and standardize the flow
'## Declare my public variables
' WorkBook
Public WB As Workbook
' Sheets
Public Req2ByWS As Worksheet
Public ReqSpecsWS As Worksheet
Public ReqInstrcWS As Worksheet
Public ConfigReqWS As Worksheet
Public AppendReqWS As Worksheet
Public AppendRlLmWS As Worksheet
' Objects (tables)
Public ReqConfigTbl As ListObject
Public SpecConfigTbl As ListObject
Public CurrRegIDTbl As ListObject
Public AppendReqTbl As ListObject
Public AppendRlLmTbl As ListObject
'## ##
'## Get Data from Tom's Functions ##
Sub GetSpotBuyData()
'## Preliminary Config ##
'## Turn OFF Warnings & Screen Updates
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'## Set global Referances to be used in routine
' WorkBooks
Set WB = Workbooks("MyWb.xlsm")
' WorkSheets
Set Req2ByWS = WB.Sheets("MyWb Pg1")
Set ReqSpecsWS = WB.Sheets("MyWb Pg2")
Set ConfigReqWS = WB.Sheets("MyWb Pg3")
Set AppendReqWS = WB.Sheets("MyWb Pg4")
Set AppendRlLmWS = WB.Sheets("MyWb Pg5")
' Tables
Set ReqConfigTbl = ConfigReqWS.ListObjects("MyWS Tbl1")
Set SpecConfigTbl = ConfigReqWS.ListObjects("MyWS Tbl2")
Set CurrRegIDTbl = ConfigReqWS.ListObjects("MyWS Tbl3")
Set AppendReqTbl = AppendReqWS.ListObjects("MyWS Tbl4")
Set AppendRlLmTbl = AppendRlLmWS.ListObjects("MyWS Tbl5")
'## Declare Routine Specefic Variables
Dim Doit As Variant
Dim Checking As Boolean
Dim Cat As String
Dim CatRtnStr As String
Dim CatChopVar As String
Dim SpecRtnStr As String
Dim SpecChopVar As String
Dim RelRtnStr As String
Dim RelChopVar As String
Dim FldVal As String
Dim FldNm As String
Dim StrFldCnt As Integer
'## 1) General Set-Up ##
'## Unprotect tabs (loop through All Tabs Unprotect)
Doit = Protct(False, WB, "Mypassword")
'## Refresh Data
Doit = RunUpdateAl(WB)
'## 2) Find the Catalgue we are playing with ##
'## Grab Catalogue input from ISR
If [Catalogue].Value = "" Then
MsgBox ("Please Enter a Catalogue")
GoTo ExitSub
Else
Cat = [Catalogue].Value
End If
'## 3) Run Toms Function and print the results to the form & Append Table ##
'## 3a) Do it for Cat Info Function
'## Get Cat Info String From Function
CatRtnStr = Prnt(Cat, "An Oracle Functions Name")
CatChopVar = CatRtnStr
If CatChopVar = "No Info" Then
MsgBox ("No Info Found in Catalogue Data Search.")
GoTo SkipCatInfoPrint
End If
'## Loop Through Data String & Write to Form
StrFldCnt = 0
Checking = True
AppendReqTbl.ListRows.Add
While Checking
'## Count String Position
StrFldCnt = StrFldCnt + 1
'## Find Current String Value & Remainder String
If InStr(CatChopVar, ";") <> 0 Then
'Multiple Values Left
FldVal = Replace(Left(CatChopVar, InStr(CatChopVar, ";")), ";", "")
CatChopVar = Right(CatChopVar, Len(CatChopVar) - InStr(CatChopVar, ";"))
Else
'Last Value
FldVal = CatChopVar
Checking = False
End If
'## Get Field Name For Current Value & Print to Form
FldNm = CStr(RefRtrn(1, CStr(StrFldCnt)))
If FldNm <> "CustomerSpecification" And FldNm <> "ShiptoAddress" Then
'Take Value as is
Req2ByWS.Range(FldNm).Value = FldVal
AppendReqTbl.ListColumns(FldNm).DataBodyRange.Value = FldVal
ElseIf FldNm = "CustomerSpecification" Then
'Replace : with New Line
FldVal = Replace(FldVal, " : ", vbLf)
Req2ByWS.Range(FldNm).Value = FldVal
AppendReqTbl.ListColumns(FldNm).DataBodyRange.Value = FldVal
ElseIf FldNm = "ShiptoAddress" Then
'Replace - with New Line
FldVal = Replace(FldVal, " - ", vbLf)
Req2ByWS.Range(FldNm).Value = FldVal
AppendReqTbl.ListColumns(FldNm).DataBodyRange.Value = FldVal
End If
Wend
'## 3b) Do it for Spec Function
SkipCatInfoPrint:
'## Get Spec Info String From Function
SpecRtnStr = Prnt(Cat, "Another Oracle Functions Name")
SpecChopVar = SpecRtnStr
If SpecChopVar = "No Info" Then
MsgBox ("No Info Found in Data Search.")
GoTo SkipSpecInfoPrint
End If
'## Loop Through Data String & Write to Form
StrFldCnt = 0
Checking = True
While StrFldCnt < 80 And (Len(SpecChopVar) - Len(Replace(SpecChopVar, ";", ""))) > 0 And Checking
'## Count String Position
StrFldCnt = StrFldCnt + 1
'## Find Current String Value & Remainder String
If InStr(SpecChopVar, ";") <> 0 Then
'Multiple Values Left
FldVal = Replace(Left(SpecChopVar, InStr(SpecChopVar, ";")), ";", "")
SpecChopVar = Right(SpecChopVar, Len(SpecChopVar) - InStr(SpecChopVar, ";"))
Else
'Last Value
FldVal = SpecChopVar
Checking = False
End If
'## Get Field Name For Current Value & Print to Form
FldNm = CStr(RefRtrn(2, CStr(StrFldCnt)))
ReqSpecsWS.Range(FldNm).Value = FldVal
AppendReqTbl.ListColumns(FldNm).DataBodyRange.Value = FldVal
Wend
'## 3c) Do it for Rel Limits Function
SkipSpecInfoPrint:
'## Get Rel Limits String From Function
RelRtnStr = Prnt(Cat, "A Third Functions Name")
RelChopVar = RelRtnStr
If RelChopVar = "No Info" Then
MsgBox ("No Info Found in Data Search.")
GoTo ExitSub
End If
'## Loop Through Data String & Write to Form
StrFldCnt = 0
Checking = True
AppendRlLmTbl.ListRows.Add
While StrFldCnt < 80 And (Len(RelChopVar) - Len(Replace(RelChopVar, ";", ""))) > 0 And Checking
'## Count String Position
StrFldCnt = StrFldCnt + 1
'## Find Current String Value & Remainder String
If InStr(RelChopVar, ";") <> 0 Then
'Multiple Values Left
FldVal = Replace(Left(RelChopVar, InStr(RelChopVar, ";")), ";", "")
RelChopVar = Right(RelChopVar, Len(RelChopVar) - InStr(RelChopVar, ";"))
Else
'Last Value
FldVal = RelChopVar
Checking = False
End If
'## Get Field Name For Current Value & Print to Form
FldNm = CStr(RefRtrn(2, CStr(StrFldCnt)))
AppendRlLmTbl.ListColumns(FldNm).DataBodyRange.Value = FldVal
Wend
AppendRlLmTbl.ListColumns("SpecificFieldName").DataBodyRange.Value = Cat
'## 4) Re-Format and Clean Up Program ##
ExitSub:
'## Clean-Up Formatting
Req2ByWS.Range("F:F", "C:C").ColumnWidth = 30
Req2ByWS.UsedRange.Rows.AutoFit
Req2ByWS.UsedRange.Columns.AutoFit
Req2ByWS.Range("G:G").ColumnWidth = 15
Req2ByWS.Range("J:R").ColumnWidth = 12
Req2ByWS.Range("D:D").ColumnWidth = 12
'## Protect tabs (loop through All Tabs Protect)
'Doit = Protct(True, WB, "Mypassword", Req2ByWS.Name)
'Req2ByWS.Unprotect ("Mypassword")
'Application.Wait (Now + TimeValue("0:00:10"))
Req2ByWS.Select
'## Turn ON Warnings & Screen Updates
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I stupidly had an enable background refresh for that specific table. An early call to refresh all data triggered the refresh, code would execute and the refresh would finally complete shortly after the code finished executing... in break mode the refresh would complete prior too. Thanks PEH for helping me look into this.
Til now the method I use to avoid going into for loops which loop through an array which is currently empty is the following:
if len(join(array,"") > 0 then
for i = 1 to ubound(array)
code
next
end if
But this is no joke, I just recently used that line of code if len(join(array,"") > 0 then and that caused the deletion of array and it crashed my program 5 times in a row. I know that sounds hard to believe but here is a screen shot
for some reason the code len(join(array,"") > 0 would destroy the variables2 array. And here is a screen shot that shows that the variables array is clearly full before I go to the bad code: So now I'm trying to use a different code I tried:
if not isempty(array) then
But that's not working. Any ideas?
If Len(Join(greek_act, "")) > 0 Then
For i = 1 To UBound(greek_act)
For j = 1 To UBound(variables2)
If greek_act(i) = variables2(j) Then
variables2(j) = ""
Exit For
End If
Next
Next
variables2 = remove_blanks(variables2)
End If
'variables2 array is full
If Len(Join(greek_letters, "")) > 0 Then
'variables2 array gets destroyed and program crashes here.
For i = 1 To UBound(greek_letters)
rightres1 = Replace(rightres1, greek_letters(i), variables2(i))
Next
End If
Never mind, I decided to just go ahead with the following solution since it appears that the program is temporarily acting up
On Error Resume Next
For i = 1 To UBound(greek_letters)
rightres1 = Replace(rightres1, greek_letters(i), variables2(i))
Next
On Error GoTo 0``
For the Join() technique to work reliably, you must complete the Dimming/ReDimming process:
Sub dural()
Dim greek_ary(1 To 3) As String
s = Join(greek_ary, "")
MsgBox Len(s)
End Sub
Without filling the array, the Len will report 0
Since this is a common test I like to use a reusable function like this:
Function IsArrayEmpty(anArray As Variant)
Dim i As Integer
On Error Resume Next
i = UBound(anArray, 1)
If Err.Number = 0 Then
IsVarArrayEmpty = False
Else
IsVarArrayEmpty = True
End If
End Function
Now in your main Sub do this:
If Not IsArrayEmpty(greek_act) Then
For i = 1 To UBound(greek_act)
For j = 1 To UBound(variables2)
If greek_act(i) = variables2(j) Then
variables2(j) = ""
Exit For
End If
Next
Next
variables2 = remove_blanks(variables2)
End If
I have problem skipping some specific part of the code while execution.
Dim turn as Integer = 1
Function recurs1()
If turn = 9 Then
GoTo Endline
End If
For i = 0 To 5
For j = 0 To 5
If (arr(i, j) <> 10 And arr(i, j) <> 20) Then
If chance Mod 2 = 1 Then
MsgBox("Intialized (" & i & "," & j & ") To 10") 'Line X
arr(i, j) = 10
ElseIf chance Mod 2 = 0 Then
MsgBox("Intialized (" & i & "," & j & ") To 20") 'Line Y
arr(i, j) = 20
End If
turn += 1 'Updating turn
recurs1() 'Recursion takes place here
End If
Next
Next
Endline:
Return Nothing
End Function
According to my understanding, the code should stop assigning values to the array after value of turn hits 9 and should return flow to the calling function/sub. However, it continues to assign values and Line X or Line Y are printed depending on the value of turn.
If allowed, the value of turn increments up to 37.
I'd surely appreciate some help with this problem from someone with a deeper understanding of the code than me.
Thank you very much.
You have placed the recursive call inside two for loops. The function will be called recursively until turn = 9, but when it returns it's still in the loop where it will be increased anyway without further checks.
Probably it would work better if you checked the value of turn just before calling the recursive function (this way you get rid of GoTo, also).
Why not just put Return Nothing where you have Goto Endline? Return stops function execution, to the best of my knowledge. That would get rid of the dreaded Goto command (it can cause messy code and inscrutable bugs).
I am working on a project. My goal is, to ping all of the computers from an excel list, but can't figure out why it isn't working. I am quite new at this programming language, and I am sure that I miss out something, because I get the error message: Object required
so here is my code
the main:
Sub pingall_Click()
Dim c As Range
c = Target.Name
For Each c In Range("A1:N50")
If (Left(c, 1) = "C" Or Left(c, 1) = "T") And IsNumeric(Right(c, 6)) And Len(c) = 7 Then
c = sPing(c)
If c = "timeout" Then
MsgBox "timeout"
ElseIf c < 16 And c > -1 Then
MsgBox "ok"
ElseIf c > 15 And c < 51 Then
MsgBox "not ok"
ElseIf c > 50 And c < 4000 Then
MsgBox "big delay"
Else
MsgBox "error"
End If
End If
Next c
End Sub
The function:
Public Function sPing(sHost) As String
Dim oPing As Object, oRetStatus As Object
Set oPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery _
("select * from Win32_PingStatus where address = '" & sHost & "'")
For Each oRetStatus In oPing
If IsNull(oRetStatus.StatusCode) Or oRetStatus.StatusCode <> 0 Then
sPing = "timeout" 'oRetStatus.StatusCode
Else
sPing = sPing & vbTab & oRetStatus.ResponseTime & Chr(10)
End If
Next
End Function
I can get the result if I write sPing(""), but I want it to get the name of pc-s that are in the list.
This is just a test version of the script, I am testing it with one pc for now, that is why I use "MsgBox".
Thank you
The 2nd line inside the Sub pingall_Click() subroutine is the one throwing the Object Required error. i.e. the following line.
c = Target.Name
If you comment it out or delete it, it works. (I tried it.)
Also, you should not be assigning the return value from the function sPing back to c.
Because doing so will overwrite the name of the Server / IP address you have in the cell, since the forloop is looping over 1 cell at a time using the c variable.
So instead, assign it back to a new string variable, and then do whatever you want with it.