Need to find a way to offset the cell value in the email body. For whichever cell value triggers the email (meaning our target has been reached) I want to return the corresponding row value 12 columns to the left. You'll see in my code I've used Target.Offset(0, -12) but this is returning an error. I hope that makes sense.
Private Sub Worksheet_Calculate()
Dim Target As Range
With Me
Set Target = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
If (Range("N45") = Range("F45")) Or (Range("N46") = Range("F46")) Or (Range("N47") = Range("F47")) Or (Range("N48") = Range("F48")) Or (Range("N50") = Range("F50")) Or (Range("N51") = Range("F51")) Or (Range("N52") = Range("F53")) Or (Range("N55") = Range("F55")) Or (Range("N56") = Range("F56")) Or (Range("N57") = Range("F57")) Or (Range("N58") = Range("F58")) Or (Range("N59") = Range("F59")) Or (Range("N61") = Range("F61")) Or (Range("N62") = Range("F62")) Or (Range("N63") = Range("F63")) Or (Range("N65") = Range("F65")) Or (Range("N66") = Range("F66")) Or (Range("N67") = Range("F67")) Or (Range("N68") = Range("F68")) Or (Range("N70") = Range("F70")) Or (Range("N71") = Range("F71")) Or (Range("N73") = Range("F73")) Or (Range("N74") = Range("F74")) Or (Range("N75") = Range("F75")) Or (Range("N76") = Range("F76")) Or (Range("N77") = Range("F77")) Or (Range("N79") = Range("F79")) Or (Range("N80") = Range("F80")) Or (Range("N81") = Range("F81")) Or (Range("N83") = Range("F83")) And _
(Range("N84") = Range("F84")) Or (Range("N85") = Range("F85")) Or (Range("N87") = Range("F87")) Or (Range("N88") = Range("F88")) Or (Range("N89") = Range("F89")) Or (Range("N91") = Range("F91")) Or (Range("N92") = Range("F92")) Or (Range("N93") = Range("F93")) Or (Range("N95") = Range("F95")) Or (Range("N96") = Range("F96")) Or (Range("N97") = Range("F97")) Or (Range("N99") = Range("F99")) Or (Range("N100") = Range("F100")) Or (Range("N101") = Range("F101")) Or (Range("N103") = Range("F103")) Or (Range("N104") = Range("F104")) Or (Range("N105") = Range("F105")) Or (Range("N106") = Range("F106")) Or (Range("N108") = Range("F108")) Or (Range("N109") = Range("F109")) Or (Range("N110") = Range("F110")) Or (Range("N111") = Range("F111")) Or (Range("N113") = Range("F113")) Or (Range("N114") = Range("F114")) Or (Range("N115") = Range("F115")) Or (Range("N116") = Range("F116")) Or (Range("N117") = Range("F117")) Or (Range("N118") = Range("F118")) Or (Range("N121") = Range("F121")) And _
(Range("N122") = Range("F122")) Or (Range("N123") = Range("F123")) Or (Range("N124") = Range("F124")) Or (Range("N125") = Range("F125")) Or (Range("N127") = Range("F127")) Or (Range("N128") = Range("F128")) Or (Range("N132") = Range("F132")) Or (Range("F134") = Range("N134")) Or (Range("N136") = Range("F136")) Or (Range("N138") = Range("F138")) Or (Range("N140") = Range("F140")) Or (Range("N142") = Range("F142")) And _
(Range("N145") = Range("F145")) Or (Range("N146") = Range("F146")) Or (Range("N147") = Range("F147")) Or (Range("N148") = Range("F148")) Or (Range("N149") = Range("F149")) Or (Range("N150") = Range("F150")) Or (Range("N153") = Range("F153")) Or (Range("N154") = Range("F154")) Or (Range("N156") = Range("F156")) Or (Range("N157") = Range("F157")) Or (Range("N159") = Range("F159")) Or (Range("N160") = Range("F160")) Or (Range("N161") = Range("F161")) Or (Range("N162") = Range("F162")) Or (Range("N163") = Range("F163")) Or (Range("N164") = Range("F164")) Or (Range("N166") = Range("F166")) Or (Range("N167") = Range("F167")) Or (Range("N168") = Range("F168")) Or (Range("N169") = Range("F169")) Or (Range("N170") = Range("F170")) Or (Range("N171") = Range("F171")) Or (Range("N173") = Range("F173")) Or (Range("N174") = Range("F174")) Or (Range("N175") = Range("F175")) Or (Range("N176") = Range("F176")) Or (Range("N177") = Range("F177")) Or (Range("N178") = Range("F178")) And _
(Range("N180") = Range("F180")) Or (Range("N182") = Range("F182")) Or (Range("N184") = Range("F184")) Or (Range("N185") = Range("F185")) Or (Range("N186") = Range("F186")) Or (Range("N187") = Range("F187")) Or (Range("N188") = Range("F188")) Or (Range("N189") = Range("F189")) Or (Range("N191") = Range("F191")) Or (Range("N192") = Range("F192")) Or (Range("N193") = Range("F193")) Or (Range("N195") = Range("F195")) Or (Range("N196") = Range("F196")) Or (Range("N197") = Range("F197")) Or (Range("N198") = Range("F198")) Or (Range("N199") = Range("F199")) Or (Range("N200") = Range("F200")) Or (Range("N201") = Range("F201")) Or (Range("N202") = Range("F202")) Or (Range("N203") = Range("F203")) Or (Range("N205") = Range("F205")) Or (Range("N206") = Range("F206")) Or (Range("N207") = Range("F207")) Or (Range("N208") = Range("F208")) Or (Range("N209") = Range("F209")) Or (Range("N210") = Range("F210")) Or (Range("N211") = Range("F211")) Or (Range("N212") = Range("F212")) And _
(Range("N213") = Range("F213")) Then
Call Mail_small_Text_Outlook
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Hi there" & vbNewLine & vbNewLine & _
Target.Offset(0, -12) & " has reached its target"
On Error Resume Next
With xOutMail
.To = "email address"
.CC = ""
.BCC = ""
.Subject = "Target Reached"
.Body = xMailBody
.Send 'or use .Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
Here I have used the Worksheet_Change event and the Offset works fine.
Dim xRg As Range
Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Target.Cells.Count > 1 Then Exit Sub
Set xRg = Intersect(Target, Range("D1:D99"))
If xRg Is Nothing Then Exit Sub
If (Range("D7") > Range("E7")) Or (Range("D8") > Range("E8")) Then
Call Mail_small_Text_Outlook
End If
End Sub
Sub Mail_small_Text_Outlook()
Dim xOutApp As Object
Dim xOutMail As Object
Dim xMailBody As String
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
xMailBody = "Hi there" & vbNewLine & vbNewLine & _
xRg.Offset(0, -3) & " has reached its target"
On Error Resume Next
With xOutMail
.To = "email address"
.CC = ""
.BCC = ""
.Subject = "Target Reached"
.Body = xMailBody
.Send 'or use .Send
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
Target.Offset(0, -12) in your Mail_small_Text_Outlook isn't defined. You can't set a variable in one subroutine and then use it in another unless that variable has been defined globally (outside of all subroutines and functions) or it is passed as a parameter to the subroutine.
Try instead:
Sub Mail_small_Text_Outlook(Target as Range)
Then calling that subroutine like:
Call Mail_small_Text_Outlook(Target)
With that you are passing the variable Target to the Mail_small_Text_Outlook subroutine.
Alternatively to set Target as a global variable so it is available to subroutines and functions in your VBAProject (I wouldn't in this case for reasons). You add to the top of your code (above your worksheet_calculate routine):
Public Target as Range
Then remove your declaration of Target in your worksheet_calculate routine:
'Dim Target As Range
Although, if you do this, then change the name of the variable since there are other built in subroutines like Worksheet_Change() that have Target as a built in variable and the scope is going to get all weird then.
Related
I am creating a yard management system to keep track of open parking spots in a lot. The userform allows the user to click on a spot in the map that is open and fill out a list of information about the truck going to that spot. Right now, if I make an error in the entry I have to redo the whole form, rather than just being able to edit the information I have already entered. Is there a way to do that without having to retype everything?
Here is the code for the user form:
Private Sub cmdCancel_Click()
Unload Me
End Sub
Private Sub cmdClear_Click()
ActiveCell.ClearContents
ActiveCell.Interior.Color = vbGreen
Unload Me
End Sub
Private Sub cmdUpdate_Click()
UpdateInfo.Show
Unload Me
End Sub
Private Sub CommandButton1_Click()
UpdateInfo.Show
Unload Me
End Sub
Private Sub UserForm_Initialize()
lblInfo = ActiveCell.Value
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set rngBDock = Range("BX7:CO7")
Set rngBulk = Range("BZ21:CG21")
Set rngTransT = Range("BF17:BY17")
Set rngTransT1 = Range("BG21:BY21")
Set rngTDock = Range("BL7:BW7")
Set rngEDock = Range("CP7:CT7")
Set rngNDock = Range("CU7:DC7")
Set rngFence = Range("CQ13:CV13")
Set rngNSide = Range("CW13:DB13")
Set rngGEO = Range("BG28:DD28")
Set rngNight = Range("CH21:DD21")
Set rngNewT = Range("DK31:DK65")
Set rngNewTl = Range("DI31:DI65")
Set rngOff = Range("BN40:CL40")
Set rngOffl = Range("BN42:CL42")
Set rng = Union(rngBDock, rngBulk, rngTransT, rngTransT1, rngTDock, rngEDock, rngNDock, rngFence, rngNSide, rngGEO, rngNight, rngNewT, rngNewTl, rngOff, rngOffl)
If Not Intersect(Target, rng) Is Nothing Then
CellInfo.Show
'ActiveCell.Value = cellFill
If Not IsEmpty(ActiveCell.Value) Then
Call RealTimeTracker
End If
End If
Private Sub cmdOkUpdate_Click()
Dim i As Integer, j As Integer
For i = 0 To lbxOption.ListCount - 1
If lbxOption.Selected(i) Then j = j + 1
Next i
If j = 0 Then
MsgBox "Please select an option. ", , "Warning"
Unload Me
UpdateInfo.Show
ElseIf j = 1 Then
NoFill = False
End If
strBOL = txtBOL.Value
strID = txtID.Value
details = txtDet.Value
opt = lbxOption.Value
currtime = time()
today = Format(Now(), "MM/DD/YYYY")
emp = TextBox1.Value
With ActiveCell
spot = .Offset(-1, 0)
If Len(spot) = 0 Then
spot = .Offset(1, 0)
Else
spot = spot
End If
End With
If NoFill = True Then
cellFill = ""
ElseIf NoFill = False Then
With Sheet5
.Range("A1").Value = "Time"
.Range("B1").Value = "Date"
.Range("C1").Value = "Location"
.Range("D1").Value = "Category"
.Range("E1").Value = "BOL"
.Range("f1").Value = "Trailer #"
.Range("g1").Value = "Details"
.Range("H1").Value = "EE Name"
.Range("A2").EntireRow.Insert
.Range("A2").Value = currtime
.Range("B2").Value = today
.Range("C2").Value = spot
.Range("D2").Value = opt
.Range("E2").Value = strBOL
.Range("F2").Value = strID
.Range("G2").Value = details
.Range("H2").Value = emp
.Columns("A:H").AutoFit
End With
If Not IsEmpty(opt) Then
cellFill = opt & " " & vbCrLf & "BOL (last 5 digits): " & strBOL & " " & vbCrLf & "Trailer # " & strID & " " & vbCrLf & details & "EE Name" & emp & " " & vbCrLf
ActiveCell.Value = cellFill
Call RealTimeTracker
End If
End If
Unload Me
Sheet1.Activate
End Sub
I've created a form where I can use a subform to load data from a query into textboxes so I can edit the data one at a time and update the database. This usually works fine except I have a run time error that randomly appears now and then - '-2147352567 (80020009)': The value you entered isn't valid for this field.'
If I stop running it and try running it again it usually works fine until the same run-time error appears. It's very inconsistent.
Private Sub btn_SelectAgency_Click()
If Not (Me.qryAgencyWithoutMileagesub.Form.Recordset.EOF And Me.qryAgencyWithoutMileagesub.Form.Recordset.BOF) Then
'get data to textbox control
With Me.qryAgencyWithoutMileagesub.Form.Recordset
Me.txt_AgencyID = .Fields("Agency ID")
Me.txt_AgencyName = .Fields("Agency Name")
Me.txt_Address1 = .Fields("Address 1")
Me.txt_Address2 = .Fields("Address 2")
Me.txt_City = .Fields("City")
Me.txt_Postcode = .Fields("Postcode")
Me.txt_AgencyMileage = .Fields("Mileage")
Me.txt_AgencyID.Tag = .Fields("Agency ID")
End With
End If
Me.txt_AgencyMileage = ""
End Sub
Private Sub btn_Update_Click()
If Me.txt_AgencyMileage = "" Then
MsgBox "No mileage added, add now"
Cancel = True
Else
CurrentDb.Execute "UPDATE EstateAgent_tbl SET EstateAgent_AgentMileage = '" & Me.txt_AgencyMileage & "' where EstateAgent_AgentID=" & Me.txt_AgencyID.Tag
Me.txt_AgencyID = ""
Me.txt_AgencyName = ""
Me.txt_Address1 = ""
Me.txt_Address2 = ""
Me.txt_City = ""
Me.txt_Postcode = ""
Me.txt_AgencyMileage = ""
End If
qryAgencyWithoutMileagesub.Form.Requery
If Me.qryAgencyWithoutMileagesub.Form.Recordset.RecordCount = 0 Then
MsgBox "No agencies without mileage"
DoCmd.Close
End If
End Sub
The error is on this line
Me.txt_AgencyID = .Fields("Agency ID")
I would appreciate any help with this, thank you :)
Dim rs As DAO.Recordset
Set rs = Me.qryAgencyWithoutMileagesub.Form.RecordsetClone
'get data to textbox control
With rs
If .RecordCount > 0 Then
Me.txt_AgencyID = .Fields("Agency ID")
Me.txt_AgencyName = .Fields("Agency Name")
Me.txt_Address1 = .Fields("Address 1")
Me.txt_Address2 = .Fields("Address 2")
Me.txt_City = .Fields("City")
Me.txt_Postcode = .Fields("Postcode")
Me.txt_AgencyMileage = .Fields("Mileage")
Me.txt_AgencyID.Tag = .Fields("Agency ID")
End If
End With
Set rs = Nothing
DoCmd.RefreshRecord
DoCmd.RunCommand acCmdUndo
'You can it try. That worked for me!
Try to exclude Null values:
If Not IsNull(.Fields("Agency ID").Value) Then
Me.txt_AgencyID.Value = .Fields("Agency ID").Value
End If
You may also try using the RecordsetClone:
Dim rs As DAO.Recordset
Set rs = Me.qryAgencyWithoutMileagesub.Form.RecordsetClone
'get data to textbox control
With rs
If .RecordCount > 0 Then
Me.txt_AgencyID = .Fields("Agency ID")
Me.txt_AgencyName = .Fields("Agency Name")
Me.txt_Address1 = .Fields("Address 1")
Me.txt_Address2 = .Fields("Address 2")
Me.txt_City = .Fields("City")
Me.txt_Postcode = .Fields("Postcode")
Me.txt_AgencyMileage = .Fields("Mileage")
Me.txt_AgencyID.Tag = .Fields("Agency ID")
End If
End With
Set rs = Nothing
I am new to VBA and am severely stuck! I have 12 cells that I need to add specific text to, but only if the cells are blank. I managed to find code for 1 of them which is shown below:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "$D$3" Then
If Target.Value = "Insert name of project (if known)" Then
Target.Font.ColorIndex = xlAutomatic
Target.Value = ""
Exit Sub
End If
End If
If [D3].Value = "" Then
[D3].Value = "Insert name of project (if known)"
[D3].Font.ColorIndex = 1
Else
[D3].Font.ColorIndex = xlAutomatic
End If
End Sub
However, seemingly I can only use this once per sheet. I need code that is similar to this that will hopefully do the same job. The remaining 11 cells need to have unique text.
Basically what I am trying to do is prompt the user to insert details in each of these cells and once the cells are filled, the form will be complete.
Any assistance is appreciated.
Hi, Apologies for the delay. This is the final edit, which works perfectly. I thought I was going to have an issue with 'undo' (CTRL+Z) but it seems to be fine now. Thanks again.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim clls(1 To 12) As String
Dim msg(1 To 12) As String
Dim i As Long, addr As String, c As Range
clls(1) = "D3": msg(1) = "Insert name of project (if known)"
clls(2) = "D4": msg(2) = "Insert closest street address"
clls(3) = "H3": msg(3) = "Insert name of landowner (if applicable)"
clls(4) = "H4": msg(4) = "Insert name of Developer (if applicable)"
clls(5) = "H6": msg(5) = "Insert name of PM Co. (if different from above)"
clls(6) = "H7": msg(6) = "Insert name of Designer (if applicable)"
clls(7) = "H8": msg(7) = "Insert name of Constructor"
clls(8) = "L3": msg(8) = "Insert project number (if known)"
clls(9) = "L6": msg(9) = "Insert name"
clls(10) = "L7": msg(10) = "Insert submission date"
clls(11) = "D10": msg(11) = "Brief description of project: Adjustment, deviation, main upsizing, main extension, lead-in, lead-out, etc."
clls(12) = "D11": msg(12) = "Insert length of asset (number only)"
Set c = Target.Cells(1)
addr = c.Address(False, False)
For i = 1 To UBound(clls)
If addr = clls(i) Then
If c.Value = msg(i) Then
c.Font.ColorIndex = xlAutomatic
c.Value = ""
End If
Else
With Me.Range(clls(i))
If .Value = "" Then
.Value = msg(i)
.Font.ColorIndex = 1
End If
End With
End If
Next i
End Sub
Might need a bit of tweaking...
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim clls(1 To 5) As String
Dim msg(1 To 5) As String
Dim i As Long, addr As String, c As Range
clls(1) = "D3": msg(1) = "Message 1"
clls(2) = "D4": msg(2) = "Message 2"
clls(3) = "D5": msg(3) = "Message 3"
clls(4) = "D6": msg(4) = "Message 4"
clls(5) = "D7": msg(5) = "Message 5"
Set c = Target.cells(1)
addr = c.Address(False, False)
For i = 1 To UBound(clls)
If addr = clls(i) Then
If c.Value = msg(i) Then
c.Font.ColorIndex = xlAutomatic
c.Value = ""
End If
Else
With Me.Range(clls(i))
If .Value = "" Then
.Value = msg(i)
.Font.ColorIndex = 1
End If
End With
End If
Next i
End Sub
my problem today is a part of a subroutine that inexplicably breaks its execution when a Workbook is closed.
I have written the following code:
Public Const Pi As Double = 3.14159265358979
Public Const Rad As Double = Pi / 180
Public CalcBook As Workbook
Public FilePath As String, Files() As String
Public FreqArray() As Integer
Sub Main()
Dim ChooseFolder As Object, FilePath As String, StrFile As String
Dim i As Integer, j As Integer, k As Integer, x As Integer
Dim DirNum As Integer, HNum As Integer, VNum As Integer
Dim DirColShift As Integer, HColShift As Integer, VColShift As Integer
Dim TheStart As Date, TheEnd As Date, TotalTime As Date
Set ChooseFolder = Application.FileDialog(msoFileDialogFolderPicker)
With ChooseFolder
.AllowMultiSelect = False
.Title = "Please choose a folder containing .txt files"
If .Show = -1 Then
FilePath = .SelectedItems(1) & "\"
Else
Set ChooseFolder = Nothing
Exit Sub
End If
End With
Set ChooseFolder = Nothing
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
' Stores only files containing an AntennaName + "_T" + any number of characters + "_?_?45.xls" string
' (where "?" is a single character and "*" is any number). Checks if the number of files is correct too.
StrFile = Dir(FilePath & "*_T*_?_?45.txt")
Do While Len(StrFile) > 0
ReDim Preserve Files(i)
Files(i) = FilePath & StrFile
i = i + 1
StrFile = Dir
Loop
If Not (UBound(Files) + 1) / 6 = Int((UBound(Files) + 1) / 6) Then GoTo FileError
For i = 0 To UBound(Files)
Select Case Right(Files(i), 9)
Case "D_+45.txt", "D_-45.txt"
DirNum = DirNum + 1
Case "H_+45.txt", "H_-45.txt"
HNum = HNum + 1
Case "V_+45.txt", "V_-45.txt"
VNum = VNum + 1
End Select
Next
If Not (DirNum / 2 = Int(DirNum / 2) And HNum / 2 = Int(HNum / 2) And VNum / 2 = Int(VNum / 2) And DirNum = HNum And HNum = VNum) Then
FileError:
MsgBox "Failed to properly load files. Looks like a wrong number of them is at dispose", vbCritical, "Check the import-files"
Exit Sub
End If
' Imports files in Excel for better data access
Set CalcBook = Application.Workbooks.Add
' FROM HERE ON THE DATA IS PROCESSED IN ORDER TO OBTAIN AN EXCEL WORKBOOK WITH 3 SHEETS CALLED "Directivity", "Horizontal" and "Vertical".
Application.ScreenUpdating = True
Options.Show
TheStart = Now
Application.ScreenUpdating = False
If Options.OnlyEval = False Then PolarCharts
If Options.OnlyCharts = False Then Auswertung
Application.DisplayAlerts = False
CalcBook.Close savechanges:=False
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Set CalcBook = Nothing
TheEnd = Now
TotalTime = TheEnd - TheStart
MsgBox Format(TotalTime, "HH:MM:SS"), vbInformation, "Computing Time"
Unload Options
End Sub
Options is a form which I need in order to access data for the PolarCharts and Auswertung. These Subs are correctly executed (I know that because the data they save is correct too).
I tried deleting the .ScreenUpdating and .DisplayAlerts commands, as well as the Unload thinking that they could bugging something, but the result hasn't changed.
Know also that the Workbook I'm closing contains NO CODE at all (and nothing else addresses a ".Close" so it's impossible that something is executed on the .Close event).
Below my "Options" code:
Private Sub Cancel_Click()
End
End Sub
Private Sub UserForm_Terminate()
End
End Sub
Private Sub Ok_Click()
If Me.OnlyCharts = False Then
ReDim SubFreq(4)
If Not (Me.Start1.ListIndex = -1 And Me.Stop1.ListIndex = -1) Then SubFreq(0) = Me.Start1.List(Me.Start1.ListIndex) & "-" & Me.Stop1.List(Me.Stop1.ListIndex)
If Not (Me.Start2.ListIndex = -1 And Me.Stop2.ListIndex = -1) Then SubFreq(1) = Me.Start2.List(Me.Start2.ListIndex) & "-" & Me.Stop2.List(Me.Stop2.ListIndex)
If Not (Me.Start3.ListIndex = -1 And Me.Stop3.ListIndex = -1) Then SubFreq(2) = Me.Start3.List(Me.Start3.ListIndex) & "-" & Me.Stop3.List(Me.Stop3.ListIndex)
If Not (Me.Start4.ListIndex = -1 And Me.Stop4.ListIndex = -1) Then SubFreq(3) = Me.Start4.List(Me.Start4.ListIndex) & "-" & Me.Stop4.List(Me.Stop4.ListIndex)
If Not (Me.Start5.ListIndex = -1 And Me.Stop5.ListIndex = -1) Then SubFreq(4) = Me.Start5.List(Me.Start5.ListIndex) & "-" & Me.Stop5.List(Me.Stop5.ListIndex)
If (Me.Start1 = "" And Me.Start2 = "" And Me.Start3 = "" And Me.Start4 = "" And Me.Start5 = "" And Me.Stop1 = "" And Me.Stop2 = "" And Me.Stop3 = "" And Me.Stop4 = "" And Me.Stop5 = "") _
Or Me.Start1.Value > Me.Stop1.Value Or Me.Start2.Value > Me.Stop2.Value Or Me.Start3.Value > Me.Stop3.Value Or Me.Start4.Value > Me.Stop4.Value Or Me.Start5.Value > Me.Stop5.Value _
Or (Me.Start1.ListIndex = -1 And Me.Stop1.ListIndex >= 0) Or (Me.Start2.ListIndex = -1 And Me.Stop2.ListIndex >= 0) Or (Me.Start3.ListIndex = -1 And Me.Stop3.ListIndex >= 0) Or (Me.Start4.ListIndex = -1 And Me.Stop4.ListIndex >= 0) Or (Me.Start5.ListIndex = -1 And Me.Stop5.ListIndex >= 0) _
Or (Me.Start1.ListIndex >= 0 And Me.Stop1.ListIndex = -1) Or (Me.Start2.ListIndex >= 0 And Me.Stop2.ListIndex = -1) Or (Me.Start3.ListIndex >= 0 And Me.Stop3.ListIndex = -1) Or (Me.Start4.ListIndex >= 0 And Me.Stop4.ListIndex = -1) Or (Me.Start5.ListIndex >= 0 And Me.Stop5.ListIndex = -1) Then
MsgBox("Please select correctly the frequency ranges - Maybe Start > Stop, one of those was not properly inserted, or the fields are blank", vbExclamation, "Frequency choice error")
GoTo hell
End If
For i = 0 To 4
If Not SubFreq(i) = "" Then j = j + 1
Next i
j = j - 1
ReDim Preserve SubFreq(j)
End If
Me.Hide
hell:
End Sub
Private Sub UserForm_Initialize()
Dim i As Byte
Me.StartMeas = Date
Me.StopMeas = Date
Me.Worker.AddItem "lol"
Me.Worker.AddItem "rofl"
Me.Worker.ListIndex = 0
For i = LBound(FreqArray) To UBound(FreqArray)
Me.Start1.AddItem FreqArray(i)
Me.Start2.AddItem FreqArray(i)
Me.Start3.AddItem FreqArray(i)
Me.Start4.AddItem FreqArray(i)
Me.Start5.AddItem FreqArray(i)
Me.Stop1.AddItem FreqArray(i)
Me.Stop2.AddItem FreqArray(i)
Me.Stop3.AddItem FreqArray(i)
Me.Stop4.AddItem FreqArray(i)
Me.Stop5.AddItem FreqArray(i)
Next i
Me.Start1.ListIndex = 0
Me.Stop1.ListIndex = Me.Stop1.ListCount - 1
End Sub
Apparently when I Close CalcBook, it triggers the UserForm_Terminate event from Options which Ends all the code! How do I avoid this?
Just remove the statement End bacause End causes the abrupt end of code execution.
I see End in the Cancel and Terminate event handlers. If you have it on other places, remove it es well.
If you need exit from a method then use Exit Sub.
Why: because End work that way. Read e.g. this post: http://www.vbforums.com/showthread.php?511766-Classic-VB-Why-is-using-the-End-statement-(or-VB-s-quot-stop-quot-button)-a-bad-idea.
If you need stop code from execution use If-condition or even Exit Sub but avoid using End for it.
Try
Workbooks("CalcBook").Close savechanges:=False
I suspect that both error alerts and indications of an error on the screen are being suppressed
I am not new to programming, but I am new to using macros in Excel. I am using Excel 2010, trying to run the following macro:
Sub HideUnhideCells(ByVal Target As Range)
Dim keyCell As Range
Set keyCell = Range("C9")
Dim Cells1 As Range
Dim Cells2 As Range
'Call the function on C9 cell change
If Target.Address = "$C$9" Then
'Make Data Source available for for DRG and UCR
If keyCell.Value = "DRG" Or keyCell.Value = "UCR" Then
Set Cells1 = Range("C33")
Cells1.EntireRow.Hidden = False
Else
Set Cells1 = Range("C33")
Cells1.EntireRow.Hidden = True
End If
'Make MSA special cells available if MSA is selected
If keyCell.Value = "MSA" Then
Set Cells1 = Range("B34:C35")
Cells1.EntireRow.Hidden = False
Else
Set Cells1 = Range("B34:C35")
Cells1.EntireRow.Hidden = True
End If
'Make UCR cells available if UCR is selected
If keyCell.Value = "UCR" Then
Set Cells1 = Range("B36:C39")
Cells1.EntireRow.Hidden = False
Else
Set Cells1 = Range("B36:C39")
Cells1.EntireRow.Hidden = True
End If
'Remove extra name cells for 1-file and 2-file values
If keyCell.Value = "DRG" Or keyCell.Value = "ICD-9" Or keyCell.Value = "NCCI_Edits" Or keyCell.Value = "UB04" Then
Set Cells1 = Range("B21:C25")
Set Cells2 = Range("B28:C32")
Cells1.EntireRow.Hidden = True
Cells2.EntireRow.Hidden = True
ElseIf keyCell.Value = "ICD-10" Or keyCell.Value = "NDC" Then
Set Cells1 = Range("B22:C25")
Set Cells2 = Range("B29:C32")
Cells1.EntireRow.Hidden = True
Cells2.EntireRow.Hidden = True
Else
Set Cells1 = Range("B21:C25")
Set Cells2 = Range("B28:C32")
Cells1.EntireRow.Hidden = False
Cells2.EntireRow.Hidden = False
End If
End If
End Sub
I have seen several postings and tutorials that talk about this, but I can't understand why this won't work. Cell C9 is a dropdown list, and I want this macro to run so that cells are shown / not shown based on what is selected in the list. However, if I give it parameters (as shown above) I can't run it in the UI, and if I don't give it parameters, I can only run it manually, which doesn't help me much.
Right now, when I select something from that C9 dropdown list, nothing happens. Can anyone help me figure out why?
Your code looked ripe for a Select Case treatment and there were several things to add about the Worksheet_Change event macro (too many for a comment) so I went ahead and wrote up a draft of the Sub Worksheet_Change. I'm not sure if I have interpreted all of the If ElseIf Else End If but perhaps you can see what I'm trying to do with this.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$C$9" Then
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo Whoa
Rows("21:25").EntireRow.Hidden = False
Rows("28:32").EntireRow.Hidden = False
Rows("33:39").EntireRow.Hidden = True
Select Case Target.Value
Case "DRG"
Rows("33").EntireRow.Hidden = False
Case "MSA"
Rows("34:35").EntireRow.Hidden = False
Case "UCR"
Rows("33").EntireRow.Hidden = False
Rows("36:39").EntireRow.Hidden = False
Case "DRG", "ICD-9", "NCCI_Edits", "UB04"
Rows("21:25").EntireRow.Hidden = True
Rows("28:32").EntireRow.Hidden = True
Case "ICD-10", "NDC"
Rows("22:25").EntireRow.Hidden = True
Rows("29:32").EntireRow.Hidden = True
Case Else
'do nothing
End Select
End If
FallThrough:
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume FallThrough
End Sub
Post back into Comments with any problem you have transcribing this for your own purposes and I'll try to assist.