For each code not making check box value true - excel

I am trying to create code that runs through a list of user ID's (B Numbers) and then when it finds the corresponding ID it checks to see if there's an X in the column directly next to it for a certain subject named SBB005 See image. If there is an X, I want the check box value to be true. The for each loop ends when it reaches a blank cell.
I have declared the 'RowYear2' and 'Year2CourseRange' ranges as public variables, and when running the code, nothing happens and the check box remains unticked! Any idea why the checkbox isn't being ticked as expected?
I am planning on setting up multiple checkboxes once this is working for all the subjects in each column:
See image
Hoping that someone can help me to get this working or may even introduce an easier way to do so for another 20 checkboxes!
Many thanks :)
Private Sub UserForm_Initialize()
Set Year2CourseRange = Sheets("Year2").Range("A:A")
For Each RowYear2 In Year2CourseRange.Cells
If RowYear2.Value = BNumberTxt Then
If RowYear2.Offset(0, 1) = "x" Then
Me.CHKSBB005.value = True
Else
Me.CHKSBB005.value = False
End If
ElseIf IsEmpty(RowYear2) Then
Exit For
End If
Next RowYear2
LoggedInTxt = Row.Offset(0, -3)
BNumberTxt = Row.Offset(0, -7)
CourseTxt = Row.Offset(0, -1)
CourseNumTxt = Row.Offset(0, -2)
End Sub
Private Sub EnterBtn_Click()
Dim LIMatch As Boolean
Dim Win As Boolean
Email = Me.EmailTxt
Password = Me.PasswordTxt
Set UserRange = Sheets("StudentInformation").Range("H:H")
For Each Row In UserRange.Cells
If Me.EmailTxt = "" And Me.PasswordTxt = "" Then
MsgBox ("Please enter an email and password")
LIMatch = False
Win = True
Exit For
ElseIf Me.EmailTxt = "" Then
MsgBox ("Please enter an email address")
LIMatch = False
Win = True
Exit For
ElseIf Me.PasswordTxt = "" Then
MsgBox ("Please enter a password")
LIMatch = False
Win = True
Exit For
Else
If UCase(Row.Value) = UCase(Email) Then
If UCase(Row.Offset(0, -6)) = UCase(Password) Then
MsgBox "Welcome"
LIMatch = True
Win = True
Attempts = 0
Exit For
ElseIf IsEmpty(Row) Then
Exit For
Win = False
Else
LIMatch = False
Win = False
Exit For
End If
Else
LIMatch = False
Win = False
End If
End If
Next Row
If LIMatch = True And Win = True Then
Unload Me
NewForm.Show
ElseIf LIMatch = False And Win = False Then
MsgBox ("Incorrect login")
Attempts = Attempts + 1
Else
End If
If Attempts >= 3 Then
MsgBox ("You have entered the incorrect login 3 times")
Unload Me
End If
End Sub

Once you fix your problem with the Row global, you can do something like this:
Private Sub UserForm_Initialize()
Dim shtData As Worksheet
Dim Year2CourseRange As Range, HeaderRange As Range, m, c As Range
Set shtData = ThisWorkbook.Sheets("Year2")
With shtData
Set Year2CourseRange = .Range("A:A")
Set HeaderRange = .Range(.Range("B2"), .Cells(2, 500).End(xlToLeft))
End With
'you'll need to fix this part....
BNumberTxt = Row.Offset(0, -7)
'etc
'find a matching row: Match() is a good approach here
m = Application.Match(BNumberTxt, Year2CourseRange, 0)
'loop over all the column headers
For Each c In HeaderRange.Cells
'Assumes all checkboxes are named "CHK[ColumnHeaderHere]"
With Me.Controls("CHK" & c.Value)
If IsError(m) Then
.Value = False 'clear all if no match
Else
.Value = (UCase(shtData.Cells(m, c.Column)) = "X") 'set if "x"
End If
End With
End If
End Sub

Ranges and Ranges
This is your code squashed a little bit and below is your data:
Private Sub UserForm_Initialize()
Set Year2CourseRange = Sheets("Year2").Range("A:A")
For Each RowYear2 In Year2CourseRange.Cells
If RowYear2.Value = BNumberTxt Then
If RowYear2.Offset(0, 1) = "x" Then
Me.CHKSBB005.value = True
Else: Me.CHKSBB005.value = False: End If
ElseIf IsEmpty(RowYear2) Then
Exit For: End If: Next RowYear2
LoggedInTxt = Row.Offset(0, -3): BNumberTxt = Row.Offset(0, -7)
CourseTxt = Row.Offset(0, -1): CourseNumTxt = Row.Offset(0, -2): End Sub
Take a look for a while, you might see the error yourself.
The CheckBox Tick Mystery
When you write Range("A:A") that refers to the whole column including Range("A1") which appears to be EMPTY. The code never even enters the If RowYear2.Offset... line but exits via the ElseIf line.
The Row Variable
I hate the idea of declaring a variable Row. But it is valid. Since there is an Offset involved, Row should be a range, probably a cell. As in the comments indicated, it has to 'survive' from another UserForm let's say UserFormX. If it has 'survived' you have to refer to it like this:
UserFormX.Row
or you have to declare it in a 'not-object' module to use only Row.
Another EnterBtn_Click
Probably useless now but here is the code I worked on the other day:
Option Explicit
Public intAttempts As Integer
Private Sub CancelBtn_Click()
Unload Me
End Sub
Private Sub EnterBtn_Click()
Const strEmail = "Please enter email address." ' Email Input Message
Const strPassword = "Please enter a password." ' Password Input Message
Const strLoginCorrect = "Welcome" ' Correct Login Message
Const strLoginIncorrect = "Incorrect Login." ' Incorrect Login Message
Const strAttempts = "Too many login attempts." ' Login Attempts Message
' Use worksheet name or index e.g. "SInfo" or 1.
Const vntWsName As String = "StudentInformation" ' Worksheet
' Use column letter or column number e.g. "F" or 6.
Const vntEmailColumn As Variant = "F" ' Email Column
Const intFirstRow As Integer = 2 ' Email Column First Row
Const intPasswordColumnOffset As Integer = -4 ' Password Column Offset
Const intMaxAttempts As Integer = 3 ' Maximum Login Attempts
Dim lngCounter As Long ' Email Column Row Counter
Dim lngLastrow As Long ' Email Column Last Row
' Check number of login attempts.
If intAttempts >= intMaxAttempts Then
MsgBox strAttempts
Exit Sub
End If
' Show annoying text messages if nothing was entered.
If Me.EmailTxt.Text = "" Then
Me.EmailTxt.Text = strEmail: Exit Sub
ElseIf Me.EmailTxt.Text = strEmail Then Exit Sub
End If
If Me.PasswordTxt.Text = "" Then
Me.PasswordTxt.Text = strPassword: Exit Sub
ElseIf Me.PasswordTxt.Text = strPassword Then Exit Sub
End If
' Check for data in specified worksheet.
With ThisWorkbook.Worksheets(vntWsName)
' Determine last row of data in Email Column.
lngLastrow = .Cells(Rows.Count, vntEmailColumn).End(xlUp).Row
For lngCounter = intFirstRow To lngLastrow
' Ceck for email in Email Column.
If UCase(.Cells(lngCounter, vntEmailColumn).Value) _
= UCase(EmailTxt.Text) Then ' Correct email.
' Check if correct password in Password Column
If UCase(.Cells(lngCounter, vntEmailColumn) _
.Offset(0, intPasswordColumnOffset).Value) _
= UCase(PasswordTxt.Text) Then ' Correct password.
Exit For
Else ' Wrong password. Set "counter" to "end".
' Faking that the loop was not interrupted.
lngCounter = lngLastrow
End If
' Else ' Wrong Email. Do nothing. Not necessary.
End If
Next
' When the loop wasn't interrupted, "lngcounter = lnglastrow + 1".
End With
' Check if loop was NOT interrupted.
If lngCounter = lngLastrow + 1 Then ' Loop was NOT interrupted.
intAttempts = intAttempts + 1
MsgBox strLoginIncorrect
Else ' Loop was interrupted. Correct email and password.
MsgBox strLoginCorrect
Unload Me
NewForm.Show
End If
End Sub

Related

Looping through multiple column : optimization

I am completely new to Macro/VBA. We have a requirement ,where I need to check different condition against multiple column and if the conditions are met, then update the final column.
I was able to code it(copied and edited) and it is working fine against small no. of records. The problem is that ,my file has 20000+ records and now the VBA is taking around 40-45 min to update "Call Down Start Date_CUSTOM" column.
Is there anyway to optimize the code or make it to run faster?
Sub Macro3_Call_down_start_date_custom()
Dim i As Long
With ActiveSheet.ListObjects(1)
For i = 1 To .DataBodyRange.Rows.Count
If .ListColumns("Activation Status").DataBodyRange(i).Value = "No" And _
.ListColumns("Call Down Start Date").DataBodyRange(i).Value = "" Then
.ListColumns("Call Down Start Date_CUSTOM").DataBodyRange(i).Value = .ListColumns("Date Added").DataBodyRange(i).Value + 3
ElseIf .ListColumns("Activation Status").DataBodyRange(i).Value = "Yes" And _
.ListColumns("Publish Date").DataBodyRange(i).Value = "" And _
.ListColumns("Time to 1st Publish POC Status").DataBodyRange(i).Value = "No First POC" Then
.ListColumns("Call Down Start Date_CUSTOM").DataBodyRange(i).Value = .ListColumns("Activation Date").DataBodyRange(i).Value
Else
.ListColumns("Call Down Start Date_CUSTOM").DataBodyRange(i).Value = .ListColumns("Call Down Start Date").DataBodyRange(i).Value
End If
Next i
End With
End Sub
set lc = ActiveSheet.ListObjects(1).ListColumns
set range1 = lc("Activation Status").DataBodyRange
set range2 = lc("Call Down Start Date").DataBodyRange
set range3 = lc("Call Down Start Date_CUSTOM").DataBodyRange
set range4 = lc("Date Added").DataBodyRange
on error goto CATCH
Application.ScreenUpdating = False
With ActiveSheet.ListObjects(1)
For i = 1 To .DataBodyRange.Rows.Count
if range1(i).Value = "No" And _
range2(i).Value = "" then
range3(i).Value = range4(i).Value + 3
elseif
...
else
...
end if
next i
end with
CATCH: Application.ScreenUpdating = True
end sub

method find of object range failed in vba

I have written a code that finds all the dye word and sum all the dye word value.
Here is the code
Dim name As String
name = "dye"
Dim findDyeRange As Range
Set findDyeRange = Range("Q10:S61")
Set firstDyeWord = findDyeRange.Find(name)
If firstDyeWord Is Nothing Then
msgbox "nothing found"
Else
firstDyeValue = firstDyeWord.Offset(0, 1).Value
Set secondDyeWord = findDyeRange.FindNext(firstDyeWord)
If secondDyeWord.Address = firstDyeWord.Address Then
MsgBox firstDyeValue
Exit Sub
Else
secondDyeValue = secondDyeWord.Offset(0, 1).Value
Set thirdDyeWord = findDyeRange.FindNext(secondDyeWord)
If thirdDyeWord.Address = firstDyeWord.Address Then
MsgBox firstDyeValue + secondDyeValue
Exit Sub
Else
thirdDyeValue = thirdDyeWord.Offset(0, 1).Value
Set fourthDyeWord = findDyeRange.FindNext(thirdDyeWord)
If fourthDyeWord.Address = firstDyeWord.Address Then
MsgBox firstDyeValue + secondDyeValue + thirdDyeValue
Exit Sub
Else
fourthDyeValue = fourthDyeWord.Offset(0, 1).Value
Set fifthDyeWord = findDyeRange.FindNext(fourthDyeWord)
If fifthDyeWord.Address = firstDyeWord.Address Then
MsgBox firstDyeValue + secondDyeValue + thirdDyeValue + fourthDyeValue
Exit Sub
Else
fifthDyeValue = fifthDyeWord.Offset(0, 1).Value
Set sixthDyeWord = findDyeRange.FindNext(fifthDyeWord)
If sixthDyeWord.Address = firstDyeWord.Address Then
MsgBox firstDyeValue + secondDyeValue + thirdDyeValue + fourthDyeValue + fifthDyeValue
Exit Sub
Else
sixthDyeValue = sixthDyeWord.Offset(0, 1).Value
MsgBox firstDyeValue + secondDyeValue + thirdDyeValue + fourthDyeValue + fifthDyeValue + sixthDyeValue
End If
End If
End If
End If
End If
End If
the code runs well. But when I removes the msgbox and set a code then it throws an error.
I want this code
If firstDyeWord Is Nothing Then
Range("A9").value = 7
But it throws error "method find of object range failed in vba"
Help Please!
According to the documentation of the Range.Find method you must at least specify the parameters LookIn, LookAt, SearchOrder and MatchByte when using Find() otherwise it uses what ever was used last by either VBA or the user interface.
Since you cannot know what your users used last in the user interface your search might randomly work and randomly come up with wrong results. Therefore always specify all of these 4 parameters to make it reliable.
Additionally you must specify in which workbook/worksheet your ranges are. Otherwise Excel guesses and it might guess the wrong sheet.
Make sure to declare all your variables properly. I recommend always to activate Option Explicit: In the VBA editor go to Tools › Options › Require Variable Declaration.
Public Sub Example()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'set your workbook and worksheet!
Dim name As String
name = "dye"
Dim findDyeRange As Range
Set findDyeRange = ws.Range("Q10:S61") 'specify in which sheet the range is
Dim firstDyeWord As Range
Set firstDyeWord = findDyeRange.Find(What:=name, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, MatchByte=False)
If firstDyeWord Is Nothing Then
'dye was NOT found
ws.Range("A9").Value = 7 'specify in which sheet the range is
Else
'do something else if dye was found
End If
End Sub
// Edit (see comment)
If this is used in an event like Worksheet_Change you need to turn off events before writing to a cell. Otherwise this will trigger another event which will trigger another event … and you get stuck in an endless loop of events, which cannot work:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'set your workbook and worksheet!
Dim name As String
name = "dye"
Dim findDyeRange As Range
Set findDyeRange = ws.Range("Q10:S61") 'specify in which sheet the range is
Dim firstDyeWord As Range
Set firstDyeWord = findDyeRange.Find(What:=name, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, MatchByte=False)
If firstDyeWord Is Nothing Then
'dye was NOT found
On Error Goto REACTIVATE_EVENTS 'in any case of error reactivate events
Application.EnableEvents = False 'disable events or .Value = 7 triggers another change event.
ws.Range("A9").Value = 7 'specify in which sheet the range is
Application.EnableEvents = True 'make sure you never leave events disabled otherwise they will stay off until you restart Excel.
Else
'do something else if dye was found
End If
Exit Sub
REACTIVATE_EVENTS:
Application.EnableEvents = True
If Err.Number <> 0 Then Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext 'show error message if there was an error.
End Sub

How to deal with a dash in an Excel VBA input variable?

I'm having some trouble with an Excel VBA macro and was hoping you could give me some advice on how to fix it. In the code below, when a user clicks a command button, an InputBox pops up and the user inputs a number in the form XXX-XXXXXX (e.g. 111-222222). Then, the macro takes the value from the column adjacent to button and uses the input variable to replace a certain part of the adjacent column's value. However, when I tried to run the macro and input a number such as 123-456789, nothing happens. I believe it has something to do with the dash that the user inputs, however I'm not sure how to fix it. Please help!
Sub CommandButtonTitleXXXdashXXXXXX_Click()
Application.ScreenUpdating = False
On Error Resume Next
Dim n As Integer
n = Worksheets("REVISIONS").Range("D3:D17").Cells.SpecialCells(xlCellTypeConstants).Count
If n = 15 Then
If MsgBox("Title revision box full. Add manually.", vbOKOnly, "Error") = vbOK Then
Exit Sub
End If
End If
Dim rs As Integer
rs = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Row
Dim amount As String
Application.ScreenUpdating = True
amount = Application.InputBox("Enter case number:", "")
Application.ScreenUpdating = False
If amount = False Then
Exit Sub
Else
Dim newCell As String
newCell = Replace(Worksheets("TITLE").Range("A" & rs).Value, "XXX-XXXXXX", amount)
Worksheets("REVISIONS").Range("D17").End(xlUp).Offset(1, 0) = newCell
End If
End Sub
I would take your code to an extra step.
No need to declare amount as String. You can keep it as a Variant. Also like I mentioned in the comment above
Can your Case number be like #D1-1%#456? If not then you have an additional problem to handle ;)
See this example. I have commented the code so that you will not have a problem understanding it. Still if you do lemme know :) The other way would be to use REGEX to validate your Case ID. Let me know if you want that example as well.
Code
Sub Sample()
Dim amount As Variant
' 123-$456789 <~~ Invalid
' 123-4567890 <~~ Valid
' ABC-&456789 <~~ Invalid
' 456-3456789 <~~ Valid
amount = Application.InputBox("Enter case number:", "")
'~~> Check if user pressed cancel
If amount = False Then Exit Sub
'~~> Check if then Case ID is valid
If IsValidCaseNo(amount) Then
MsgBox amount
Else
MsgBox "Invalid case ID"
End If
End Sub
Function IsValidCaseNo(sAmount) As Boolean
Dim s As String
Dim i As Long, j As Long
s = sAmount
'
'~~> Initial basic checks
'
'~~> Check if the length is 11 characters
If Len(Trim(s)) <> 11 Then GoTo Whoa
'~~> Check if the string contains "-"
If InStr(1, s, "-") = 0 Then GoTo Whoa
'~~> Check if the 4th character is a "-"
If Mid(s, 4, 1) <> "-" Then GoTo Whoa
'~~> Loop through 1st 3 characters and check
'~~> If they are numbers
For i = 1 To 3
Select Case Asc(Mid(s, i, 1))
Case 48 To 57
Case Else: GoTo Whoa
End Select
Next
'~~> Loop through last 6 characters and check
'~~> If they are numbers
For i = 5 To 11
Select Case Asc(Mid(s, i, 1))
Case 48 To 57
Case Else: GoTo Whoa
End Select
IsValidCaseNo = True
Next
Whoa:
End Function
If you Dim amount as String, you can test it as a string:
Sub GetDash()
Dim amount As String
amount = Application.InputBox(Prompt:="Enter case number", Type:=2)
If amount = "False" Then
MsgBox "You cancelled"
End If
End Sub

If IsEmpty then go to column A but in same row and extract that data

I am creating a spreadsheet which has many columns and I am trying to make it check if a cell in a certain column is empty then it will check to see the cells in the other columns of the same row are empty. Currently the only way I know of is if you say exactly what cell you are checking.
'Checking If the "Email Sent Columb cells are empty so it can be set to "No"
If IsEmpty(ThisWorkbook.Sheets(2).Range("F2")) Then
ThisWorkbook.Sheets(2).Range("F2") = "No"
If IsEmpty(ThisWorkbook.Sheets(2).Range("J2")) Then
ThisWorkbook.Sheets(2).Range("J2") = "No"
If IsEmpty(ThisWorkbook.Sheets(2).Range("M2")) Then
ThisWorkbook.Sheets(2).Range("M2") = "No"
End If
End If
End If
'If Acknowledge Email Sent = No then it will check if there are any fields that are empty if not then it will send the email and mark
'it as sent
If ThisWorkbook.Sheets(2).Range("F2") = "No" Then
If IsEmpty(ThisWorkbook.Sheets(2).Range("A2")) Then
MsgBox "A2 Empty"
Else
If IsEmpty(ThisWorkbook.Sheets(2).Range("B2")) Then
MsgBox "B2 Empty"
Else
If IsEmpty(ThisWorkbook.Sheets(2).Range("C2")) Then
MsgBox "C2 Empty"
Else
If IsEmpty(ThisWorkbook.Sheets(2).Range("D2")) Then
MsgBox "D2 Empty"
Else
If IsEmpty(ThisWorkbook.Sheets(2).Range("E2")) Then
MsgBox "E2 Empty"
Else
MsgBox "Acknowledge Email Ready To Be Sent"
ThisWorkbook.Sheets(2).Range("F2") = "Yes"
End If
End If
End If
End If
End If
End If
'If Update Email Sent = No then it will check if further evidence is required if it is then it will check if the evidence required is
'not empty, if it isnt empty then it will send the email and mark it as sent, but if further evidence required is set to no then it
'will mark it as unnecessary.
If ThisWorkbook.Sheets(2).Range("J2") = "No" Then
If ThisWorkbook.Sheets(2).Range("H2") = "Yes" Or ThisWorkbook.Sheets(2).Range("H2") = "" Then
If IsEmpty(ThisWorkbook.Sheets(2).Range("H2")) Then
MsgBox "H2 Is Empty"
Else
If IsEmpty(ThisWorkbook.Sheets(2).Range("I2")) Then
MsgBox "I2 Is Empty"
Else
MsgBox "Update Email Ready To Be Sent"
ThisWorkbook.Sheets(2).Range("J2") = "Yes"
End If
End If
Else
ThisWorkbook.Sheets(2).Range("J2") = "Unnecessary"
End If
End If
If ThisWorkbook.Sheets(2).Range("M2") = "No" Then
If ThisWorkbook.Sheets(2).Range("L2") = "" Then
MsgBox "L2 Is Empty"
Else
If ThisWorkbook.Sheets(2).Range("L2") = "Approved with Pay" Then
MsgBox "Approved with Pay Email Sent"
ThisWorkbook.Sheets(2).Range("M2") = "Yes"
Else
If ThisWorkbook.Sheets(2).Range("L2") = "Approved without Pay" Then
MsgBox "Approved without Pay Email Sent"
ThisWorkbook.Sheets(2).Range("M2") = "Yes"
Else
If ThisWorkbook.Sheets(2).Range("L2") = "Approved in Part" Then
MsgBox "Approved in Part Email Sent"
ThisWorkbook.Sheets(2).Range("M2") = "Yes"
Else
If ThisWorkbook.Sheets(2).Range("L2") = "Referred back to the Line Manager" Then
MsgBox "Approved without Pay Email Sent"
ThisWorkbook.Sheets(2).Range("M2") = "Yes"
End If
End If
End If
End If
End If
End If
This is how I have edited the below code, but it doesn't seem to be working
Option Explicit
Sub Test3()
End Sub
Public Function CheckIfRowIsEmpty(ByVal P2 As Range, _
ByVal colsToCheck As Integer) As Boolean
Dim isRowEmpty As Boolean
Dim startRow As Integer
Dim endRow As Integer
Dim a As Integer
isRowEmpty = True
If IsCellEmpty(wb.Sheets(2).Range("P2")) = True Then
startRow = P2.Column
endRow = P2.Column + (13 - 1)
For a = startRow To endRow
If IsCellEmpty(P2.Offset(, a)) = False Then
isRowEmpty = False
Exit For
End If
Next a
Else
isRowEmpty = False
End If
Debug.Print CStr(isRowEmpty)
CheckIfRowIsEmpty = CStr(isRowEmpty)
End Function
Private Function IsCellEmpty(ByVal P2 As Range) As Boolean
If Len(P2.Value & "") < 1 Then
IsCellEmpty = True
Else
IsCellEmpty = False
End If
End Function
I believe what you are looking for is to understand the range object. When you call Range("P2") or Range("P2:Z2"), you are asking for a range object.
In short: you can think of them as a collection of variables and methods(functions).
And in VBA, to use objects as variable you need to set them (a simple equality won't work):
So in your case you'd do:
Dim rng as Range
Set rng = Range("A2")
And if you want it to be set to something else, you need to set it using a function that returns a range object. (e.g. Cells(...), Offset(...), etc.)
And to check if a cell is empty. You'd ask for the value property and compare it to "":
If (rng.Value = "") then
And if you are looking to grab the cell with the same row but in column A, you'd use Cells instead of Range.
Cells(rng.Row,1).value

When reading down a column of Excel file, how to define cell coordinates without selecting a cell?

Can anyone tell me how to improve this macro?
All the macro does is it just reads an Excel file for a list a accounts to update in an application (SmarTerm Beta). It technically already accomplishes the goal, but is there a way to code it so that while it’s reading the Excel file, the coordinates of the cells from which to read the account numbers and also the coordinates of the cells in which to write an output don’t depend on a "pre-selected" a cell? The risk with selecting a cell is that if someone were to accidentally select a different cell while the macro is running, everything will get screwed up.
Here's my current code:
Public oExcelObj As Object
Function WaitSystem(Optional NoDialog as Variant) As Boolean
Dim nContinue as Integer
Dim nTimeOut as Integer 'In seconds.
'The default timeout for each command is 3 minutes.
'Increase this value if your host requires more time
'for each command.
nTimeOut = 10
If IsMissing(NoDialog) then NoDialog = False
'Wait for response from host.
Session.EventWait.Timeout = nTimeOut
Session.EventWait.EventType = smlPAGERECEIVED
Session.EventWait.MaxEventCount = 1
WaitSystem = True
If Session.EventWait.Start = smlWAITTIMEOUT Then
If NoDialog Then
WaitSystem = False
Else
nContinue = QuerySyncError()
If nContinue <> ebYes then WaitSystem = False
End If
End If
Set LockStep = Nothing
End Function
'Establish link. Search for Excel.
Function OleLinkConnection
Const XlMaximized = &HFFFFEFD7
Titlebar$ = AppFind$("Microsoft Excel")
If Titlebar$ <> "" Then
bIsExcelActive = True
If AppGetState(Titlebar$) = ebMinimized Then
AppSetState 2, Titlebar$
End If
Else
bIsExcelActive = False
End If
If bIsExcelActive Then
'Create Excel Object using current instance of Excel.
Set oExcelObj = GetObject(, "Excel.Application")
Else
'Create Excel Object using a new instance of Excel.
Set oExcelObj = CreateObject("Excel.Application")
End If
Version = oExcelObj.Application.Version
oExcelObj.ScreenUpdating = True
oExcelObj.Displayalerts = True
oExcelObj.Visible = true
End Function
Sub JPBmacro
Dim AccountNumber As String
Dim Temp As Integer
Begin Dialog StartDialogTemplate ,,211,74,"Run JPBmacro?"
OKButton 60,12,92,20,.Proceed
CancelButton 60,40,92,20,.Exit
End Dialog
Dim StartDialog As StartDialogTemplate
r% = Dialog(StartDialog)
If r% = 0 Then End
g$ = "G:\DATA\outputfile.xlsx"
oleCode = OleLinkConnection
oExcelObj.Workbooks.Open g$
oExcelObj.Range("A1").Select ‘<----This selects the cell from which all coordinates are based off of. The coordinates of oExcelObj.ActiveCell.Offset(Y,X).Value VBA depend on selecting a cell.
NEXTACCOUNT:
Temp = 0
AccountNumber = oExcelObj.ActiveCell.Offset(Temp,0).Value
While AccountNumber <> ""
Session.SendKey "CLEAR"
If WaitSystem = False Then End
Session.Send "ACTU " & AccountNumber
Session.SendKey "ENTER"
If WaitSystem = False Then End
If Trim(Session.ScreenText(4,6,1,22)) = "INVALID ACCOUNT NUMBER" Or Trim(Session.ScreenText(4,6,1,19)) = "ACCOUNT NOT ON FILE" Then
oExcelObj.ActiveCell.Offset(Temp,1).Value = Trim(Session.ScreenText(4,6,1,22))
GoTo RESTARTLOOP
End If
UPDATEIOV:
If Trim(Session.ScreenText(13,76,1,1)) = "Y" Then
oExcelObj.ActiveCell.Offset(Temp,1).Value = "Account already flagged as institutional."
Else
Session.Row = 13
Session.Column = 76
Session.send "Y"
Session.SendKey "ENTER"
If WaitSystem = False Then End
oExcelObj.ActiveCell.Offset(Temp,1).Value = Trim(Session.ScreenText(24,2,1,50))
End If
RESTARTLOOP:
Temp = Temp + 1
AccountNumber = oExcelObj.ActiveCell.Offset(Temp,0).Value
Wend
ENDNOW:
oExcelObj.Workbooks.Close
MsgBox "All Done!"
End Sub
Why not keep the reference to the first cell?
Dim rng as Range
Set rng = oExcelObj.Range("A1")
i=1
...
x = rng.Cell(i,1).Value
'Or faster yet is reading all the values into an variant array.
Dim array() as Variant
array = rng.Resize(N,M).Value
' Work with array as
x = array(i,1)
Given the comment from assylias and that another poster has since "answered" with this approach:
I can't see where oExcelObj is instantiated? Or how you are referring to a specific sheet.
Regardless of which,
you can avoid select by setting a range, ie Set rng1 = oExcelObj.Sheets(1).Range("A1")
and then use offsets from rng1.
The user won't be able to interfere while the code is running

Resources