First, I have used my eyes and Ctrl+F and another person's eyes to check for End If, I do not see why I get this error message:
Compile error: Block If Without End If
I have tried to indent macro correctly, hope it is clear to read.
This is the entire function since I am not sure where the error message is. The compiler selects the End Sub at the very end of this function.
Sub settings()
' Goal of this function: to get user-desired settings and request permission to clear sheet
' could write these settings to text file and create profiles so that user can skip entering all this every time?
Dim cases As Variant
Dim title As String
title = "K-Map Program"
cases = InputBox("Enter number of inputs.", title)
If Not IsNumeric(cases) Then
Call notnum
End If
clearsheet = MsgBox("Permission to clear Sheet1?", vbYesNo + vbQuestion, title) ' could upgrade by giving user choice of which sheet to clear
If clearsheet = vbYes Then
MsgBox ("Clearing sheet1.")
Sheet1.Cells.Clear
ElseIf clearsheet = vbNo Then
MsgBox ("Sheet1 has not been cleared, program is ending.")
Exit Sub
Else
Call errormessage
End If
numforswitch = MsgBox("Do you want to label the inputs as numbers (1, 2, 3...)?", vbYesNo + vbQuestion, title)
' deposit the switches in columns in 0, 1 format
If numforswitch = vbYes Then
ifshift = MsgBox("Shift=0?", vbYesNo + vbQuestion, title)
If ifshift = vbYes Then
For counter = 1 To cases
Cells(1, counter).Value2 = counter ' will print 1, 2, 3... in the columns
Next
ElseIf shift = vbNo Then
shift = InputBox("What's shift?")
For counter = 1 To cases
Cells(1, counter).Value2 = counter + shift ' will print x, x+1...
Next
ElseIf numforswitch = vbNo Then
MsgBox ("Using letters for switches.")
' alphabet array
Const ALPHABET As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
Dim i As Integer
For i = 1 To VBA.Len(ALPHABET)
Cells(1, i).Value = VBA.Mid(ALPHABET, i, 1)
Next i
Else
Call errormessage
End If
End Sub
Your missing end-if is in this block:
If ifshift = vbYes Then
For counter = 1 To cases
Cells(1, counter).Value2 = counter ' will print 1, 2, 3... in the columns
Next
ElseIf shift = vbNo Then
shift = InputBox("What's shift?")
For counter = 1 To cases
Cells(1, counter).Value2 = counter + shift ' will print x, x+1...
Next
You should cleanup/format your code so you can easily spot issues like this. If you don't make your code look nice and orderly, you'll waste a lot of time with problems like this.
Related
I need to suspend macro execution until all calculations are finished.
I tried using loops with and without DoEvents checking CalculationState but the loop never ends.
Do Until Application.CalculationState = xlDone
DoEvents
Loop
Have you looked at handling the application's AfterCalculate() event (see https://learn.microsoft.com/en-us/office/vba/api/excel.application.aftercalculate)?
You need to create a class which contains the Application object in order to access the handler. You can then call whatever routine you wish from there. If you had more than one routine to call depending on what is being calculated you could set, say, an enum to point to the right procedure. I've called this class cApp and skeleton code for that would be:
Option Explicit
Public Enum ProcAferCalcCode
None
DeliveryProc
TimeProc
End Enum
Private WithEvents mApp As Application
Private mProcAfterCalcCode As ProcAferCalcCode
Public Property Let ProcAfterCalc(RHS As ProcAferCalcCode)
mProcAfterCalcCode = RHS
End Property
Private Sub Class_Initialize()
mProcAfterCalcCode = None
Set mApp = Application
End Sub
Private Sub mApp_AfterCalculate()
Select Case mProcAfterCalcCode
Case DeliveryProc
SetDeliveryOptions
Case TimeProc
SetTime
End Select
End Sub
In this example, I have a one-row table that looks like this:
When the user enters a quantity, and the 'Price' cell calculates (A * B), a routine is called that populates the validation list in the 'Delivery' column. When a delivery option is selected, and the 'Cost' cell calculates (A * D), a routine is called that retrieves delivery times. It's a trite example, but should give you an idea on how to code it.
Code in a module looks like this:
Option Explicit
Private mApp As cApp
Public Sub RunMe()
Debug.Print "RunMe() called..."
If MsgBox("Ready to enter qty?", vbYesNo) = vbYes Then
Debug.Print "Some user action confirmed."
Set mApp = New cApp
mApp.ProcAfterCalc = DeliveryProc
End If
Debug.Print "RunMe() ended."
Debug.Print "** No procedure is running **" & vbNewLine
End Sub
Public Sub SetDeliveryOptions()
Dim cell As Range
Dim del As String
Debug.Print "SetDeliveryOptions() called..."
mApp.ProcAfterCalc = None
Set cell = Sheet1.ListObjects("Table1").ListColumns("Price").DataBodyRange
Debug.Print "Price is " & cell.Value2
'Mimic some task.
Select Case cell.Value2
Case 0
del = vbNullString
Case Is < 5
del = "$5 - Standard"
Case Is < 10
del = "$5 - Standard, $6 - Express"
Case Else
del = "$5 - Standard, $6 - Express, $7 - Next Day"
End Select
With cell.Offset(, 1)
.Value = Empty
With .Validation
.Delete
.Add xlValidateList, xlValidAlertStop, xlBetween, del
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End With
mApp.ProcAfterCalc = TimeProc
Debug.Print "SetDeliveryOptions() ended."
Debug.Print "** No procedure is running **" & vbNewLine
End Sub
Public Sub SetTime()
Dim cell As Range
Dim d As Long
Debug.Print "SetTime() called..."
mApp.ProcAfterCalc = None
Set cell = Sheet1.ListObjects("Table1").ListColumns("Delivery").DataBodyRange
Debug.Print "Delivery Option is " & cell.Value
'Mimic some other task.
Select Case cell.Value2
Case Is = "$5 - Standard"
d = Int((10 - 5 + 1) * Rnd + 5)
Case Is = "$6 - Express"
d = Int((5 - 2 + 1) * Rnd + 2)
Case Is = "$7 - Next Day"
d = 1
Case Else
d = 0
End Select
cell.Offset(, 1) = d
Debug.Print "SetTime() ended."
Debug.Print "** No procedure is running **" & vbNewLine
End Sub
The immediate window outputs the following:
RunMe() called...
Some user action confirmed.
RunMe() ended.
** No procedure is running **
SetDeliveryOptions() called...
Price is 25
SetDeliveryOptions() ended.
** No procedure is running **
SetTime() called...
Delivery Option is $7 - Next Day
SetTime() ended.
** No procedure is running **
What state is it in?
List item xlCalculating 1 Calculations in process.
List item xlDone 0 Calculations complete.
List item xlPending 2 Changes that trigger calculation have been made, but a recalculation has not yet been performed.
It might help you determine what is happening on your worksheets.
In the code I am posting, I am using a check box called "ACDS Test" and whenever it is checked it creates a sheet, then when it becomes unchecked it calls the upper function and deletes the sheet.
I am trying to add a message box that essentially works like a fail safe to ensure they want to delete the page. If they say they do not want to delete the page then I want the checkbox to stay checked.
For some reason I am getting this error message when I try to pass the value to make sure the checkbox stays checked and I cannot figure out why.
The error comes up on the line:
Sub ACDSTest_Click(CorrectValue As Integer)
And the specific error is: "Compile error: Procedure Declaration does not match description of event or procedure having the same name".
Any help is much appreciated! IF any more clarification is needed please feel free to ask!
Sub DeleteWorksheet(NameSheet As String)
Dim Ans As Long
Dim t As String
Dim CorrectValue As Integer
Dim i As Long, k As Long
k = Sheets.Count
Ans = MsgBox("Would you like to take this test off of the form?", vbYesNo)
Select Case Ans
Case vbYes
'Code reads through each page and finds one with corresponding name to string t
'Once it finds the correct page, it deletes it
For i = k To 1 Step -1
t = Sheets(i).Name
If t = NameSheet Then
Sheets(i).Delete
End If
Next i
CorrectValue = 0
Case vbNo
CorrectValue = 1
End Select
End Sub
Sub ACDSTest_Click(CorrectValue As Integer)
Dim NameSheet As String
Dim NameValue As String
NameSheet = "ACDS"
NameValue = "ACDS Test"
If ACDSTest.Value = True Then
CreateWorksheet (NameSheet), (NameValue)
Worksheets("Sheet1").Activate
Else
DeleteWorksheet (NameSheet)
If CorrectValue = 1 Then
ActiveSheet.Shapes("ACDS Test").ControlFormat.Value = 1
End If
End If
End Sub
The issue here is that the CorrectValue variable as you define it in DeleteWorksheet does not exist in the context of the
variable does not exist in context of the ACDSTest_Click subroutine. This is because variables defined within subroutines or functions are local to those functions. To correct this I would convert DeleteWorksheet to a function such as the below.
Further, the event that fires Private Sub ACDSTest_Click() cannot handle passing a value to that function, so changing it to Sub ACDSTest_Click(CorrectValue As Integer) causes an error.
Function DeleteWorksheet(ByVal SheetName As String) As Boolean
On Error GoTo SheetDNE
SheetName = Sheets(SheetName).Name 'Check if sheet exists w/o other objects
On Error GoTo 0
Select Case MsgBox("Would you like to take this test off of the form?", vbYesNo)
Case vbYes
Application.DisplayAlerts = False
Sheets(SheetName).Delete
Application.DisplayAlerts = True
DeleteWorksheet = True
Case Else: DeleteWorksheet = False
End Select
Exit Function 'Exit The Function w/o error
SheetDNE: 'Sheet Does Not Exist
MsgBox "The indicated sheet, " & SheetName & ", does not exist", vbOKOnly
End Function
And
Private Sub ACDSTest_Click()
Dim NameSheet As String
Dim NameValue As String
NameSheet = "ACDS"
NameValue = "ACDS Test"
If ACDSTest.Value = True Then
CreateWorksheet (NameSheet), (NameValue)
Worksheets("Sheet1").Activate
Else
If Not DeleteWorksheet(NameSheet) Then _
ActiveSheet.Shapes("ACDS Test").ControlFormat.Value = 1
End If
End Sub
I am writing a code to color user's input to a written questions. I am fairly new to vba, the code is working fine but I want to improve it, that is detect errors and incase something goes wrong with the code the documents still functions normally.
I have two types of input, either the user select something from dropdown menu or write his/her own answer (usually numbers, so I have a function to trim the answer for numbers incase there was character).
example:
Q:Number of work hours?
A: Five (5) ----> the code check the value (5) and based on it the "Five (5)" color changes to green.
I appreciate your help.
Private Sub App_DocumentBeforeSave(ByVal Doc As Document, SaveAsUI As
Boolean, Cancel As Boolean)
Dim store As String
Dim storeNum As Integer
If ActiveDocument.Bookmarks.Exists("high") = True Then
store = ActiveDocument.Bookmarks("high").Range.Text
If store = "0" Then
ActiveDocument.Bookmarks("high").Range.Font.TextColor = RGB(103, 106, 110)
Else
ActiveDocument.Bookmarks("high").Range.Font.TextColor = vbRed
End If
End If
If ActiveDocument.Bookmarks.Exists("medium") = True Then
End If
If (ActiveDocument.Bookmarks.Exists("bidders") = True) And (ActiveDocument.Bookmarks("bidders").Range.Text <> "Number of primary bids received and alternatives") Then
storeNum = ExtractNumber(ActiveDocument.Bookmarks("bidders").Range)
If storeNum > 7 Then
ActiveDocument.Bookmarks("bidders").Range.Font.TextColor = RGB(0, 176, 80)
ElseIf (storeNum > 3) And (storeNum < 8) Then
ActiveDocument.Bookmarks("bidders").Range.Font.ColorIndex = wdDarkYellow
ElseIf storeNum < 4 Then
ActiveDocument.Bookmarks("bidders").Range.Font.TextColor = vbRed
End If
End If
For Each oContentControl In ActiveDocument.ContentControls
If oContentControl.Type = wdContentControlRichText Then
oContentControl.Range.Font.Color = RGB(103, 106, 110)
oContentControl.Range.Font.Name = "Trebuchet MS"
oContentControl.Range.Font.Size = 11
oContentControl.Application.ActiveDocument.Paragraphs.Alignment = wdAlignParagraphJustify
End If
Next
ActiveDocument.Fields.Update
End Sub
Function ExtractNumber(rCell As Range)
Dim iCount As Integer, i As Integer
Dim sText As String
Dim lNum As String
sText = rCell
For iCount = Len(sText) To 1 Step -1
If IsNumeric(Mid(sText, iCount, 1)) Then
i = i + 1
lNum = Mid(sText, iCount, 1) & lNum
End If
If i = 1 Then lNum = CInt(Mid(lNum, 1, 1))
Next iCount
ExtractNumber = CLng(lNum)
End Function
Well... it is a broad question but there a few problems nonetheless:
If (ActiveDocument.Bookmarks.Exists("bidders") = True) And ActiveDocument.Bookmarks("bidders").Range.Text <> "Number of primary bids
received and alternatives") Then
Because both parts of the And are evaluated. In other words, even if the bookmark "bidders" does not exist you are still asking for the text, which generates an error.
A better way would be to use a nested If:
If (ActiveDocument.Bookmarks.Exists("bidders") = True) Then
If ActiveDocument.Bookmarks("bidders").Range.Text <> "Number of primary bids received and alternatives") Then
' Your Code
End If
End If
Also this If block is empty (best to delete it):
If ActiveDocument.Bookmarks.Exists("medium") = True Then
End If
You may also run into trouble with the content controls, sometimes they can be locked for editing in which case you may expect an error when you try to set the font .name, .color, .size.
You can test and set whether or not a content control is locked with this:
If activedocument.ContentControls(1).LockContents = True Then ' Prevent edit
If activedocument.ContentControls(1).LockContentControl = True Then ' Prevent delete
' Note you don't actually need the " = True", it is just there for clarity
Recently I have been tasked with making a calculator in VB. It must include stuff like logic or denary/binary/hex conversions. When I was making the binary->denary conversion I encountered a thing where an if statement checking if the inputted number is binary always returned true and activated. Here is the code for the binary conversion system: (please forgive me for the goto's)
Private Sub bbin_Click(sender As Object, e As EventArgs) Handles bbin.Click
If temp = IsNumeric(inputbox.Text) Then
MessageBox.Show("Value Not Numeric", "ERROR", MessageBoxButtons.OK)
inputbox.Text = ""
Else
For i = 1 To Len(inputbox.Text)
If Mid(inputbox.Text, i, 1) <> "0" Or Mid(inputbox.Text, i, 1) <> "1" Then
MessageBox.Show("Value Not Binary", "ERROR", MessageBoxButtons.OK)
inputbox.Text = ""
GoTo skipbin
End If
Next
For x = 1 To Len(inputbox.Text)
If Mid(inputbox.Text, x, 1) = "1" Then
decnum = decnum + 2 ^ (Len(inputbox.Text) - (x - 1))
End If
Next
binnum = inputbox.Text
inputbox.Text = ""
End If
textbox.Text = "Dec = " + decnum.ToString + " Bin = " + binnum.ToString + " Hex = " + hexnum.ToString
skipbin:
End Sub
Let me explain:
The inputbox is the place where the user can input the numbers/operations. The first If checks if the value inputed is a number.
Then a check is ran to ensure the number is binary. (this is where im having problems)
The conversion is ran. It doesn't work as intended at the moment, but I'm sure I'll get it working.
Then the binary and denary values get displayed in a second textbox that I use to display the answers.
The problem I'm having is only with this section: (again, forgive me for the goto functions)
For i = 1 To Len(inputbox.Text)
If Mid(inputbox.Text, i, 1) <> "0" Or Mid(inputbox.Text, i, 1) <> "1" Then
MessageBox.Show("Value Not Binary", "I AM ERROR", MessageBoxButtons.OK)
inputbox.Text = ""
GoTo skipbin
End If
Next
It's supposed to check each digit if it's a 1 or a 0, and if not, it displays an error and skips the conversion.
What do I need to change to make the input validation work as intended?
You need And instead of Or.
When you get a bit of code that you can't figure out why it doesn't work, it is often a good idea to make the minimal bit of code that shows the problem - removing everything else can often lead you to the problem.
In this case, to confirm my answer was correct, I used this:
Option Infer On
Option Strict On
Module Module1
Sub Main()
Dim s = "000012"
For i = 1 To Len(s)
Dim c = Mid(s, i, 1)
If c <> "0" And c <> "1" Then
Console.WriteLine("Value Not Binary: {0}", c)
End If
Next
Console.ReadLine()
End Sub
End Module
You can use AndAlso instead of And: it eliminates any unnecessary processing of the clauses (known as short-circuiting). Similarly, there is OrElse instead of Or.
Your problem is your condition result is always true for any binary number.
try this instead
Dim currentChar = CInt(Mid(InputBox.Text, i, 1))
If currentChar <> 0 And currentChar <> 1 Then
MessageBox.Show("Value Not Binary", "ERROR", MessageBoxButtons.OK)
InputBox.Text = ""
GoTo skipbin
End If
I would like to know how to lookup a value selected from a Listbox (clicked) using application.worksheetfunction.match(lookup_value, lookuparray, match type)
edit:
This is a "supposed" to be a button (Reservebutton) the "ReservationName" is a textbox the reserve button adds the number from the available listbox to the reserved listbox and then deletes the number selected in the available listbox. i'm a beginner in coding, so mind my mistakes please.
thanks a lot.
Private Sub ReserveButton_Click()
Dim Locator, RowData, NListBoxValue As Double
Locator = Application.WorksheetFunction.Count(Worksheets("Reserved").Range("A:A"))
For r = 0 To AvailableNumberList.ListCount - 1
RowData = Application.WorksheetFunction.Match(AvailableNumberList.List(r), Worksheets("Activation").Range("A:A"), 0)
If AvailableNumberList.Selected(r) = True Then
If ReservationName.Value = "" Or ReservationName.Value = "Enter Full Name" Then
ErrorResult = MsgBox("Error: Name field is empty", vbCritical + vbOKOnly, "Error In Field")
ElseIf Application.WorksheetFunction.VLookup(AvailableNumberList.List(r), Activation.Range("A:E"), 4, False) <> "FREE" Then
ErrorResult = MsgBox("Error: Number is Not Free", vbCritical + vbOKOnly, "Error In Reservation")
Else
ReservedNumberList.AddItem AvailableNumberList.List(r)
Worksheets("Reserved").Range("A" & Locator + 2) = AvailableNumberList.List(r)
Worksheets("Reserved").Range("B" & Locator + 2) = Worksheets("Activation").Cells(RowData, 2)
Worksheets("Reserved").Range("C" & Locator + 2) = Worksheets("Activation").Cells(RowData, 3)
Worksheets("Reserved").Range("D" & Locator + 2) = ReservationName.Value
AvailableNumberList.Clear
Worksheets("Reserved").Rows(RowData).Delete
ThisWorkbook.Save
Call AvailableList
End If
End If
Next r
End Sub
Code:
Application.WorksheetFunction.Match(<Form>.<Listbox>,Range("<LookupSheet>!A:A"),0)