Call Userform when a certain parameter is not met using VBA - vba

I am currently working on an excel sheet where I am trying to basically have a userform appear once my If...Then Statement is true. My "If, Then" statement bascially consists of the data point being above the maximum or below the minimum.
Once the data point meets those parameters, that is when I want to call the Userform. I am trying to have the Userform to display an entry for a number and once entered, it will make sure that it is not above the maximum or below the minimum. Then if it is not above the maximum or below the minimum, I would want to submit that number that was entered into the cell where the user inputted the data. I know it may seem simple but I am fairly new to VBA and I am trying my best to learn it. So far with the UserForm I got up to designing it. So I just entered text and and entry box. That is about it. Thank you for the Help!
Also here is my code that I have for the "If, Then" Statement. I orginially had it where it sends an email. So after the "Then" term. I made the macro send an email to the owner of that excel sheet. I am trying to use this code as well to make the UserForm:
Option Explicit
Public Sub OutofControl()
Dim lRow As Long
Dim lstRow As Long
Dim data As Variant
Dim ul As Variant
Dim ll As Variant
Dim wb As Workbook
Dim ws As Worksheet
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
Set ws = Sheets(2)
ws.Select
lstRow = WorksheetFunction.Max(1, ws.Cells(Rows.Count, "R").End(xlUp).Row)
For lRow = 1 To lstRow
data = Cells(lRow, "E").Value
ul = Range("K26")
ll = Range("K25")
If data > ul Or data < ll Then
If IsNumeric(data) = True And data Like "" = False Then
' Code for Sending Email after Then
Now Here is my code on the Sheet with the Selection Change After I did some research. However I am getting an infinite loop and the Input box is not entering the data I type. Also the "Run OutofControl" line in the code refers to another macro that sends out an automatic email.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim lRow As Long
Dim lstRow As Long
Dim KeyCells As Range
Dim data As Variant
Dim ul As Variant
Dim ll As Variant
Dim ws As Worksheet
Set ws = Sheets(2)
ws.Select
lstRow = WorksheetFunction.Max(1, ws.Cells(Rows.Count, "R").End(xlUp).Row)
For lRow = 1 To lstRow
data = Cells(lRow, "E").Value
ul = Range("K26")
ll = Range("K25")
' The variable KeyCells contains the cells that will
' cause an alert when they are changed.
Set KeyCells = Range("E:E")
If (data > ul) Or (data < ll) Then
Application.EnableEvents = False
If IsNumeric(data) = True And data Like "" = False Then
Run ("OutofControl") 'Macro
Application.EnableEvents = False
' Display a message when one of the designated cells has been
' changed.
Application.EnableEvents = True
On Error GoTo 0
MsgBox ("There was an Out of Control Point at " & Cells(lRow, "C").Value)
Teststr = InputBox("Enter your Control data:")
End If
End If
Next lRow
End Sub

Much easier to do this with a InputBox!
TestStr = InputBox("Enter your data:")
'If... Then conditions
Range("Cell Name").Value = TestStr
Then test that string against your parameters.
EDIT: Updated for new criteria:
Dim StrPrompt As String
Dim TestStr As Long
StrPrompt = "How many data?"
redo:
TestStr = Application.InputBox(StrPrompt, "Enter an integer number (numbers will be rounded)", , , , , , Type:=1)
If TestStr > ul or lngNum < ll Then
StrPrompt = "How many data - this must be between " & ll & " and " & ul
GoTo redo
End If
Cells(lRow, "E").Value = TestStr

Related

Trouble Shoot Why VBA Stops running mid macro and never finishes execution

As the title suggests, I was running the below macro. Weirdly enough the msgBox never prompts me with an End Time nor does an error message pop up when the macro stops running. The data in the folders is pretty straight forward stuff, however there are roughly a thousand files its going through
Any pointers on how to trouble shoot this myself? This is something I need to get better at, so suggestions on what to do to figure it out would be nice.
Sub AbesLoop()
Dim wbk As Workbook
Dim ws As Integer
Dim Filename As String
Dim path As String
Dim rCell As Range
Dim rRng As Range
Dim wsO As Worksheet
Dim StartTime As Double
Dim SecondsElapsed As Double
Dim sheet As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
StartTime = Timer
'On Error Resume Next
path = "PATHtoStuff" & "\"
Filename = Dir(path & "*.xl??")
Set wsO = ThisWorkbook.Sheets("Sheet1")
Do While Len(Filename) > 0
DoEvents
Set wbk = Workbooks.Open(path & Filename, True, True)
ws = wbk.Worksheets.count
'For i = 1 To ws
For Each sheet In ActiveWorkbook.Worksheets
If sheet.Index > 1 Then
Set rRng = Range("b1:b308")
For Each rCell In rRng.Cells
If rCell <> "" And rCell.Value <> "Not Tested" And rCell.Value <> 0 Then
wsO.Cells(wsO.Rows.count, 1).End(xlUp).Offset(1, 0).Value = rCell
wsO.Cells(wsO.Rows.count, 1).End(xlUp).Offset(0, 1).Value = rCell.Offset(0, -1)
wsO.Cells(wsO.Rows.count, 1).End(xlUp).Offset(0, 2).Value = Mid(Right(ActiveWorkbook.FullName, 15), 1, 10)
End If
Next rCell
End If
Next
'Next i
wbk.Close False
Filename = Dir
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
Edit: turns out that for some reasom the loop code is looking at sheet tab 1. I changed the code to try and account for that but for some reason is is still looking at the first page. The error is a "mismatch type" before the dashboard on the first sheet (which I keep trying to circumvent) keeps running into a formula error.
When working in VBA that's part of an application it's important to use the objects provided by the application, rather than generalized Selection or ActiveWorkbook, etc. This code is doing that, which is good :-)
At the same time, however, VBA needs to be able to uniquely identify object with which it should work. With "Selection" or "Active[Thing]" that's not necessary, so this step isn't something easily learned using the macro recorder.
In the case of the code in this question
Set rRng = Range("b1:b308")
It's not clear to Excel from which worksheet the Range should be taken, so it's defaulting to the first worksheet in the workbook. Instead, use:
Set rRng = sheet.Range("b1:b10")"

Display a row of data

I need a row of data from an Excel spreadsheet to display when I search for an Organization code. I can get a cell to show but not the row of information. There is an error message if the Organization does not match any on the file.
Here is what I have so far:
Option Explicit
Sub findData()
Dim GCell As Range
Dim Txt$, MyPath$, MyWB$, MySheet$
Dim myValue As String
Txt = InputBox("What Organization do you want to search for?")
MyPath = "C:\users\DKane\My Documents\"
MyWB = "EVHC Master Hiring Spreadsheet range find.xlsx"
MySheet = ActiveSheet.Name
Application.ScreenUpdating = False
Workbooks.Open Filename:=MyPath & MyWB
Set GCell = ActiveSheet.Cells.Find(Txt)
With ThisWorkbook.ActiveSheet.Range("A1")
.Value = "Organization"
.Offset(0, 1).Value = "Location"
.Offset(1, 0).Value = GCell.Value
myValue = GCell.Offset(0, 1).Value
.Offset(1, 1).Value = myValue
.Columns.AutoFit
.Offset(1, 1).Columns.AutoFit
End With
ActiveWorkbook.Close savechanges:=False
Application.ScreenUpdating = True
Exit Sub
and the header line info (across the top of the sheet):
HR Contact (person who can answer questions about this org)
Region
Organization (Company.Location Code.Department)
Location in Oracle format
Job Title
PT/FT
Local Tax Element
Benefits Code
Benefits Code Comments (if multiple, how can MHRC determine what benefit code should be used?)
Mailstop
Internal Transfer?
Payroll ID
Local Tax Element
Union Code
Union Code Comments (if multiple, how can MHRC determine when to use which code?)
Uniform Allowance
PTO Date
Drug Screen Provider (e.g. Quest, internal, Concentra)
Sign-on bonus instructions (including under what circumstances each is used, if multiple)
See this code. From what I read, I think it will give you what you are asking for.
I placed comments in the code itself where I made changes (that may not be obvious), so you can understand.
Option Explicit
Sub findData()
Dim GCell As Range
Dim Txt$, MyPath$, MyWB$, MySheet$
Dim myValue As String
Dim wbMain As Workbook
Set wbMain = ThisWorkbook
Txt = InputBox("What Organization do you want to search for?")
MyPath = "C:\users\DKane\My Documents\"
MyWB = "EVHC Master Hiring Spreadsheet range find.xlsx"
Dim ws As Worksheet
Set ws = wbMain.Sheets("Sheet1") ' change as needed
'MySheet = ws.Name
Application.ScreenUpdating = False
Dim wbSearch As Workbook
Set wbSearch = Workbooks.Open(Filename:=MyPath & MyWB)
Set GCell = wbSearch.Sheets(1).Cells.Find(Txt) 'assumes its first worksheet in workbook
If Not GCell Is Nothing Then 'test if it exists
'get last column
Dim lCol As Long
lCol = wbSearch.Range("A1").End(xlToRight).Column 'assumes contigous column headers
'copy headers
wbSearch.Range(.Range(.Range("A1"), .Cells(1, lCol))).Copy ws.Range("A1")
'copy org rows
wbSearch.Range(.Range(.Cells(GCell.Row, 1), .Cells(GCell.Row, lCol))).Copy ws.Range("B1")
ws.Columns.AutoFit
Else
MsgBox "Org Not Found"
End If
wbSearch.Close savechanges:=False
Application.ScreenUpdating = True
End Sub

Inserting Comment and Color into a cell that satisfies If...Then Statement

So I am basically trying to insert a comment and color the cell that basically meets the criteria that I set in my code. I searched all over but cant seem to find a viable solution.
Here is the code that I have so far and I mentioned in the code below where I would like the color and comment to be. The way I have this macro set up is that it gets "Called" from the Worksheet. I used the Selection_Change function. So I have a range where in one column someone enters data and then whatever data is entered the following macro runs and checks to see if it is within limits.
If it is not within the limits that are set in the excel sheet ("M7" and "M19"), I would like a color to highlight that certain cell and a set comment in that cell. How would I go about this? I really appreciate the help. Thank you!
Also I found a code online and my problem is that when i use the
ActiveCell.AddComment ("Text")
I keep getting an error, and also after I enter my data point and I press enter, the comment goes into the next cell.
Here is the macro that gets called:
Option Explicit
Public Sub OutofControlRestofData()
Dim lRow As Long
Dim lstRow As Long
Dim data As Variant
Dim ul As Variant
Dim ll As Variant
Dim wb As Workbook
Dim ws As Worksheet
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
Set ws = Sheets(2)
ws.Select
lstRow = WorksheetFunction.Max(1, ws.Cells(Rows.Count, "R").End(xlUp).Row)
For lRow = 1 To lstRow
data = Cells(lRow, "E").Value
ul = Range("M7")
ll = Range("M19")
If data > ul Or data < ll Then
If IsNumeric(data) = True And data Like "" = False Then
MsgBox ("There was an Out of Control Point at " & Cells(lRow, "C").Value)
'THIS IS WHERE I THINK THE COMMENTING AND COLOR CODE WOULD BE
End If
End If
Next lRow
End Sub
Also here is the code that Calls the Macro:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Target.Worksheet.Range("E39:E138")) Is Nothing Then
Run ("OutofControlRestofData")
End If
End Sub
A few things to note.
You should practice using tab to "nest" your If statements. Makes
it clearer to see.
You can go ahead and combine the two Subs. Just make sure you put the code in the Sheet's code page (not in a workbook module).
You don't need a loop if you already have a "Target" as that is the cell (Range) you want to check anyways.
You have defined your Change sub to only work if the data entry is between E39 and E138. Will this always be the case? Consider using the entire column E if you want more flexibility to grow your sheet and data.
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Set ws = Sheets(2)
If Not Intersect(Target, ws.Range("E39:E138")) Is Nothing Then
Dim lRow As Long
Dim lstRow As Long
Dim data As Variant
Dim ul As Variant
Dim ll As Variant
Dim wb As Workbook
Dim ws As Worksheet
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
data = Target.Value
ul = Range("M7").Value
ll = Range("M19").Value
If data > ul Or data < ll Then
If IsNumeric(data) = True And data Like "" = False Then
MsgBox ("There was an Out of Control Point at " & Target.Address)
Target.Interior.Color = RGB(255, 0, 0)
Target.AddComment ("This is an Out of Control Point")
End If
End If
End If
End Sub
Just to be on the safe side, I'd recommend changing your code here to include value:
data = Range("E" & lRow).Value
ul = Range("M7").Value
ll = Range("M19").Value
Then in the spot where you want to do the color/comment stuff:
Range("E" & lRow).Interior.Color = RGB(255, 0, 0)
Range("E" & lRow).AddComment("This is an Out of Control Point")

Test data in variable range for missing information and notify submitter

I am new to VBA and building off of someone else's code, who was newer to VBA than me! Thanks in advance for any tips and advice you may have.
Since I cannot post the image I will attempt to describe the dataset. The data is from a userform, with the bulk of the content in a table range A14:M34, with questions in column A, and data in columns B-M. The first row is a header the user populates identifying the unit inspected. The data below is populated with pull downs with blank, Yes and NO as options, and a few rows with numeric or character strings.
I want to test each cell in a variably sized range for unanswered questions and notify the user if there are any and give them the option to complete the dataset before submitting.
Sub new_p()
Static AbortProc As Boolean
Dim iRow As Long
Dim LastColumn As Long
Dim aCol As Long
Dim ws As Worksheet, WS1 As Worksheet
Dim InputRange As Range
Set ws = Worksheets("PreparationData")
Set WS1 = Worksheets("ColdWeatherPreparation")
Set InputRange = WS1.Range("B15:M34")
If AbortProc Then Exit Sub
'find last column in range
LastColumn = WS1.Cells(14, 2).End(xlToRight).Column
'define variable range of columns
For aCol = 2 To LastColumn
'check that the circuit row is not blank
'If Cells(14, aCol) Is Not Nothing Then
If IsEmpty(InputRange) Then
Msg = "All fields are not populated. Stop submission to resume editing?"
Ans = MsgBox(Msg, vbYesNo)
'if yes stop process
If Ans = vbYes Then
AbortProc = True
Exit Sub
End If
'if no run rest of script
If Ans = vbNo Then
MsgBox "Run without Correcting?"
AbortProc = False
Exit Sub
End If
End If
'End If
Next
'more code here that seems to be working
End Sub
You'll see I have commented out a line I think is redundant. If End(xlToRight) generates the last populated column of the header row then they are not blank, so no need to test. Nonetheless I keep code I am not using until the final checks are done and it is proven to be completely useless. The excessive commenting is to help a large group of non-VBA staffers follow and verify my code before implementing.
So the LastColumn definition seems to work, and I use it again later. When I step through the code it cycles through the correct number of times for my bogus dataset. I feel like the isEmpty is where I am falling down.
If every cell in B15:M34 should be non-blank, then you can do this:
If Application.CountBlank(InputRange)>0 Then
If Msgbox(Msg, vbYesNo) = vbYes Then
'rest of your code
End If
End If
EDIT: this will check each data cell against the corresponding header cell.
Sub new_p()
Static AbortProc As Boolean
Dim iRow As Long
Dim LastColumn As Long
Dim aCol As Long
Dim ws As Worksheet, WS1 As Worksheet
Dim InputRange As Range, rw As Range
Dim HeaderRange As Range
Dim x As Long, Msg As String
Set ws = Worksheets("PreparationData")
Set WS1 = Worksheets("ColdWeatherPreparation")
Set HeaderRange = WS1.Range("B14:M14")
Set InputRange = WS1.Range("B15:M34")
'are you sure about this next line?
'once validation has failed once how does it re-run?
If AbortProc Then Exit Sub
For Each rw In InputRange.Rows
For x = 1 To rw.Cells.Count
If Len(rw.Cells(x).Value) = 0 And _
Len(Headerange.Cells(x).Value) > 0 Then
Msg = "All fields are not populated. Stop submission" & _
" to resume editing?"
If MsgBox(Msg, vbYesNo) = vbYes Then
AbortProc = True
Exit Sub
Else
MsgBox "Run without Correcting?"
AbortProc = False
Exit Sub
End If
End If
Next x
Next rw
'more code here that seems to be working
End Sub
Errors at Len line? Maybe, because Cells has 2 parameters? Cells(RowIndex,ColumnIndex).
Also, you can set LastColumn by:
LastColumn = ActiveSheet.UsedRange.Columns.Count
same thing can be done for rows:
LastRow = ActiveSheet.UsedRange.Rows.Count
Maybe you should move If AbortProc Then Exit Sub inside For loop (as first/last line)

Excel Macro for creating new worksheets

I am trying to loop through some columns in a row and create new worksheets with the name of the value of the current column/row that I am in.
Sub test()
Range("R5").Select
Do Until IsEmpty(ActiveCell)
Sheets.Add.Name = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
Loop
End Sub
This code creates the first one correctly starting at R5 but then it appears that the macro switches to that worksheet and doesn't complete the task.
The Sheets.Add automatically moves your selection to the newly created sheet (just like if you insert a new sheet by hand). In consequence the Offset is based on cell A1 of the new sheet which now has become your selection - you select an empty cell (as the sheet is empty) and the loop terminates.
Sub test()
Dim MyNames As Range, MyNewSheet As Range
Set MyNames = Range("R5").CurrentRegion ' load contigeous range into variable
For Each MyNewSheet In MyNames.Cells ' loop through cell children of range variable
Sheets.Add.Name = MyNewSheet.Value
Next MyNewSheet
MyNames.Worksheet.Select ' move selection to original sheet
End Sub
This will work better .... you assign the list of names to an object variable of type Range and work this off in a For Each loop. After you finish you put your Selection back to where you came from.
Sheets.Add will automatically make your new sheet the active sheet. Your best bet is to declare variables to your objects (this is always best practice) and reference them. See like I've done below:
Sub test()
Dim wks As Worksheet
Set wks = Sheets("sheet1")
With wks
Dim rng As Range
Set rng = .Range("R5")
Do Until IsEmpty(rng)
Sheets.Add.Name = rng.Value
Set rng = rng.Offset(0, 1)
Loop
End With
End Sub
Error handling should always be used when naming sheets from a list to handle
invalid characters in sheet names
sheet names that are too long
duplicate sheet names
Pls change Sheets("Title") to match the sheet name (or position) of your title sheet
The code below uses a variant array rather than a range for the sheet name for performance reasons, although turning off ScreenUpdating is likely to make the biggest difference to the user
Sub SheetAdd()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim strError As String
Dim vArr()
Dim lngCnt As Long
Dim lngCalc As Long
Set ws1 = Sheets("Title")
vArr = ws1.Range(ws1.[r5], ws1.[r5].End(xltoRight))
If UBound(vArr) = Rows.Count - 5 Then
MsgBox "sheet range for titles appears to be empty"
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
lngCalc = .Calculation
End With
For lngCnt = 1 To UBound(vArr)
Set ws2 = Sheets.Add
On Error Resume Next
ws2.Name = vArr(lngCnt, 1)
If Err.Number <> 0 Then strError = strError & vArr(lngCnt, 1) & vbNewLine
On Error GoTo 0
Next lngCnt
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = lngCalc
End With
If Len(strError) > 0 Then MsgBox strError, vbCritical, "These potential sheet names were invalid"
End Sub
This is probably the simplest. No error-handling, just a one-time code to create sheets
Sub test()
Workbooks("Book1").Sheets("Sheet1").Range("A1").Activate
Do Until IsEmpty(ActiveCell)
Sheets.Add.Name = ActiveCell.Value
Workbooks("Book1").Sheets("Sheet1").Select
ActiveCell.Offset(0, 1).Select
Loop
End Sub