VBA Code Not Working after Error Check - vba

I am trying to use the below to check values are not exceeded in ranges B14 & E21. If the values in either of these ranges are exceeded, then a msgbox should appear to advise the user of the error.
I have error checked the code and it is not highlighting any errors, but when I go to run it nothing is happening.
Option Explicit
Sub TooManyHolidays()
Dim msg As String
Dim Ans As VbMsgBoxResult
If Sheets("Request Form").Range("B14") < 26 And Sheets("Request Form").Range("E21") < 10 Then
NewBookingCheck.NewBookingCheck
ElseIf Sheets("Request Form").Range("B14") >= 26 Then
msg = (" You Dont Have Enough Holiday ")
Ans = MsgBox(msg, vbYesNo)
If Ans = vbNo Then
Sheets("Request Form").Select
Range("Employee3").ClearContents
Range("DateRequest").ClearContents
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
Application.Quit
End If
If Ans = vbYes Then
Sheets("Request Form").Select
Range("Employee3").ClearContents
Range("DateRequest").ClearContents
Range("Employee3") = Application.Username
ElseIf Sheets("Request Form").Range("E21") >= 10 Then
msg = (" You Cant Book More Than 10 Or More Days In One Request ")
Ans = MsgBox(msg, vbYesNo)
If Ans = vbNo Then
Sheets("Request Form").Select
Range("Employee3").ClearContents
Range("DateRequest").ClearContents
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
Application.Quit
End If
If Ans = vbYes Then
Sheets("Request Form").Select
Range("Employee3").ClearContents
Range("DateRequest").ClearContents
Range("Employee3") = Application.Username
End If
End If
End If
End Sub


I think the code below will give you what you wanted (even though I don't know what is NewBookingCheck.NewBookingCheck), or what are you doing if both Range("B14") and Range("E21") are inside the permitted values.
Option Explicit
Sub TooManyHolidays()
Dim msg As String
Dim Ans As VbMsgBoxResult
With Sheets("Request Form")
If .Range("B14") < 26 And .Range("E21") < 10 Then
NewBookingCheck.NewBookingCheck '<-- don't know what this does ?
ElseIf .Range("B14") >= 26 Then
msg = (" You Dont Have Enough Holiday ")
Ans = MsgBox(msg, vbYesNo)
If Ans = vbNo Then
Range("Employee3").ClearContents
Range("DateRequest").ClearContents
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
Application.Quit
End If
If Ans = vbYes Then
Range("Employee3").ClearContents
Range("DateRequest").ClearContents
Range("Employee3") = Application.UserName
End If
ElseIf .Range("E21") >= 10 Then '<-- this should be directly below "If .Range("B14") < 26 And .Range("E21") < 10 Then"
msg = (" You Cant Book More Than 10 Or More Days In One Request ")
Ans = MsgBox(msg, vbYesNo)
If Ans = vbNo Then
Range("Employee3").ClearContents
Range("DateRequest").ClearContents
Application.DisplayAlerts = False
ThisWorkbook.Save
Application.DisplayAlerts = True
Application.Quit
End If
If Ans = vbYes Then
Range("Employee3").ClearContents
Range("DateRequest").ClearContents
Range("Employee3") = Application.UserName
End If
End If
End With
End Sub

Related

Issues with My Web Query Macro

I wrote a Web Query macro to import financial statements from Yahoo Finance based on the value in cell A1. It was working seamlessly for the past few weeks, but suddenly, it no longer returns any data (but does not generate an error). If anyone has any insights, I would appreciate your guidance. I have posted the code below--thank you!
Sub ThreeFinancialStatements()
On Error GoTo Explanation
Rows("2:1000").Select
Selection.ClearContents
Columns("B:AAT").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
Dim inTicker As String
inTicker = Range("A1")
ActiveSheet.Name = UCase(inTicker)
GetFinStats inTicker
Exit Sub
Explanation:
MsgBox "Please make sure you type a valid stock ticker symbol into cell A1 and are not trying to create a duplicate sheet." & _
vbLf & " " & _
vbLf & "Also, for companies with different classes of shares (e.g. Berkshire Hathaway), use a hyphen to designate the ticker symbol instead of a period (e.g. BRK-A)." & _
vbLf & " " & _
vbLf & "Please also note that not every company has three years of financial statements, so data may appear incomplete or missing for some companies.", _
, "Error"
Exit Sub
End Sub
Sub GetFinStats(inTicker As String)
'
' GetBalSheet Macro
'
'
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://finance.yahoo.com/q/bs?s=" & inTicker & "+Balance+Sheet&annual", Destination:= _
Range("$D$1"))
.Name = "bs?s=PEP+Balance+Sheet&annual"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "9"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://finance.yahoo.com/q/is?s=" & inTicker & "+Income+Statement&annual", Destination _
:=Range("$J$1"))
.Name = "is?s=PEP+Income+Statement&annual"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "9"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://finance.yahoo.com/q/cf?s=" & inTicker & "+Cash+Flow&annual", Destination:= _
Range("$P$1"))
.Name = "cf?s=PEP+Cash+Flow&annual"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "9"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Range("A3").Select
ActiveCell.FormulaR1C1 = "Current Ratio"
Range("A4").Select
ActiveCell.FormulaR1C1 = "Quick Ratio"
Range("A5").Select
ActiveCell.FormulaR1C1 = "Cash Ratio"
Range("A6").Select
Range("A7").Select
ActiveCell.FormulaR1C1 = "Revenue Growth Rate"
Range("A9").Select
Columns("A:A").ColumnWidth = 21.86
ActiveCell.FormulaR1C1 = "ROA"
Range("A10").Select
ActiveCell.FormulaR1C1 = "ROE"
Range("A11").Select
ActiveCell.FormulaR1C1 = "ROIC"
Range("B3").Select
ActiveCell.Formula = "=F11/F28"
Range("B4").Select
ActiveCell.Formula = "=(F11-F8)/F28"
Range("B5").Select
ActiveCell.Formula = "=F5/F28"
Range("B7").Select
ActiveCell.Formula = "=(L2/N2)^(1/2)-1"
Range("B9").Select
ActiveCell.Formula = "=L35/SUM(F12:F18)"
Range("B10").Select
ActiveCell.Formula = "=L35/F47"
Range("B11").Select
ActiveCell.Formula = "=L35/(F47+SUM(F29:F33))"
Range("B3").Select
Selection.NumberFormat = "0.00"
Range("B4").Select
Selection.NumberFormat = "0.00"
Range("B5").Select
Selection.NumberFormat = "0.00"
Range("B7").Select
Selection.NumberFormat = "0.00%"
Range("B9").Select
Selection.NumberFormat = "0.00%"
Range("B10").Select
Selection.NumberFormat = "0.00%"
Range("B11").Select
Selection.NumberFormat = "0.00%"
Range("A1").Select
End Sub

Your code is obviously working against a specific worksheet:
Rows("2:1000").Select
But what sheet is that? Only you can know that.
As written, it's whatever the active worksheet is, regardless of how much sense that makes.
Unqualified, these functions all implicitly refer to the ActiveSheet:
Range
Cells
Columns
Rows
Names
So you need to qualify them. And you do that by specifying a specific Worksheet object they should be working with - suppose that's DataSheet (I've no idea):
DataSheet.Rows("2:1000").Select
That would .Select the specified rows on the worksheet pointed to by the DataSheet object.
By why do you need to .Select it? This:
Rows("2:1000").Select
Selection.ClearContents
Could just as well be:
DataSheet.Rows("2:1000").ClearContents
Or better - assuming your data is formatted as a table (seems it looks like one anyway - so why not use the ListObjects API?):
DataSheet.ListObjects("DataTable").DataBodyRange.Delete
Sounds like that instruction has just replaced all the .Select and .ClearContents going on here. Note that .Select mimicks user action - the user clicking on a cell (or anything really) and selecting it. You have programmatic access to the entire object model - you never need to .Select anything!
Dim inTicker As String
inTicker = Range("A1")
Here you're implicitly reading from the active sheet, but you're also implicitly converting a Variant (the cell's value) into a String, which may or may not succeed. If A1 contains an error value (e.g. #REF!), the instruction fails.
With DataSheet.Range("A1")
If Not IsError(.Value) Then
inTicker = CStr(.Value)
Else
'decide what to do then
End If
End With
Your error-handling subroutine should at least Debug.Print Err.Number, Err.Description so that you have a bit of a clue about why things blew up. Right now it's assuming a reason for failure, and as you saw, Excel is full of traps.
Also you're using vbLf, but that's only half of a proper Windows newline character. Use vbNewLine if you're not sure what that is.
An Exit Sub instruction just before an End Sub token is completely useless.
Sub GetFinStats(inTicker As String)
The procedure is implicitly Public, and inTicker is implicitly passed ByRef. Kudos for giving it an explicit type!
This would be better:
Private Sub GetFinStats(ByVal inTicker As String)
With ActiveSheet.QueryTables
At least that's explicit about using the active sheet. But should it use the active sheet, or a specific sheet? And what happens to the query tables that were already there?
I strongly recommend you type this in the immediate pane:
?ThisWorkbook.Connections.Count
If the number is greater than the number of .QueryTables.Add calls you have in your procedure (likely), you have quite a problem there: I suspect you have over a hundred connections in the workbook, and clicking the "Refresh All" button takes forever to finish, and it's fairly possible that finance.yahoo.com is receiving dozens of requests from a single IP in a very limited amount of time, and refuses to serve them.
Delete all unused workbook connections. And then fix the implicit ActiveSheet references there too, and get rid of all these useless .Select calls:
With TheSpecificSheet
With .QueryTables.Add( ... )
End With
With .QueryTables.Add( ... )
End With
With .QueryTables.Add( ... )
End With
'assgin .Value, not .FormulaR1C1; you're not entering a R1C1 formula anyway
.Range("A3").Value = "Current Ratio"
.Range("A4").Value = "Quick Ratio"
.Range("A5").Value = "Cash Ratio"
End With
Consecutive .Select calls mean all but the last one serve a purpose, if any:
Range("A6").Select
Range("A7").Select
Again, don't assign ActiveCell when you can assign .Range("A7").Value directly.
And you can set number formats for a range of cells:
.Range("B3:B11").NumberFormat = "0.00%"

You can still retrieve the necessary data by parsing JSON response either from
https://finance.yahoo.com/quote/AAPL/financials(extracting data from HTML content, AAPL here just for example)
or via API
https://query1.finance.yahoo.com/v10/finance/quoteSummary/AAPL?lang=en-US&region=US&modules=incomeStatementHistory%2CcashflowStatementHistory%2CbalanceSheetHistory%2CincomeStatementHistoryQuarterly%2CcashflowStatementHistoryQuarterly%2CbalanceSheetHistoryQuarterly%2Cearnings
You may use the below VBA code to parse response and output result. Import JSON.bas module into the VBA project for JSON processing. Here are Sub Test_query1_finance_yahoo_com() to get data via API and Test_finance_yahoo_com_quote to extract data from HTML content:
Option Explicit
Sub Test_query1_finance_yahoo_com()
Dim sSymbol As String
Dim sJSONString As String
Dim vJSON As Variant
Dim sState As String
sSymbol = "AAPL"
' Get JSON via API
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://query1.finance.yahoo.com/v10/finance/quoteSummary/" & sSymbol & "?lang=en-US&region=US&modules=incomeStatementHistory%2CcashflowStatementHistory%2CbalanceSheetHistory%2CincomeStatementHistoryQuarterly%2CcashflowStatementHistoryQuarterly%2CbalanceSheetHistoryQuarterly%2Cearnings", False
.Send
sJSONString = .ResponseText
End With
' Parse JSON response
JSON.Parse sJSONString, vJSON, sState
If sState = "Error" Then
MsgBox "Invalid JSON"
Exit Sub
End If
' Pick core data
Set vJSON = vJSON("quoteSummary")("result")(0)
' Output
QuoteDataOutput vJSON
MsgBox "Completed"
End Sub
Sub Test_finance_yahoo_com_quote()
Dim sSymbol As String
Dim sJSONString As String
Dim vJSON As Variant
Dim sState As String
sSymbol = "AAPL"
' Get webpage HTML response
With CreateObject("Msxml2.XMLHTTP")
.Open "GET", "https://finance.yahoo.com/quote/" & sSymbol & "/financials", False
.Send
sJSONString = .ResponseText
End With
' Extract JSON from HTML content
sJSONString = "{" & Split(sJSONString, "root.App.main = {")(1)
sJSONString = Split(sJSONString, "}(this));")(0)
sJSONString = Left(sJSONString, InStrRev(sJSONString, "}"))
' Parse JSON response
JSON.Parse sJSONString, vJSON, sState
If sState = "Error" Then
MsgBox "Invalid JSON"
Exit Sub
End If
' Pick core data
Set vJSON = vJSON("context")("dispatcher")("stores")("QuoteSummaryStore")
' Output
QuoteDataOutput vJSON
MsgBox "Completed"
End Sub
Sub QuoteDataOutput(vJSON)
Const Transposed = True ' Output option
Dim oItems As Object
Dim vItem
Dim aRows()
Dim aHeader()
' Fetch main structures available from JSON object to dictionary
Set oItems = CreateObject("Scripting.Dictionary")
With oItems
.Add "IncomeStatementY", vJSON("incomeStatementHistory")("incomeStatementHistory")
.Add "IncomeStatementQ", vJSON("incomeStatementHistoryQuarterly")("incomeStatementHistory")
.Add "CashflowY", vJSON("cashflowStatementHistory")("cashflowStatements")
.Add "CashflowQ", vJSON("cashflowStatementHistoryQuarterly")("cashflowStatements")
.Add "BalanceSheetY", vJSON("balanceSheetHistory")("balanceSheetStatements")
.Add "BalanceSheetQ", vJSON("balanceSheetHistoryQuarterly")("balanceSheetStatements")
.Add "EarningsChartQ", vJSON("earnings")("earningsChart")("quarterly")
.Add "FinancialsChartY", vJSON("earnings")("financialsChart")("yearly")
.Add "FinancialsChartQ", vJSON("earnings")("financialsChart")("quarterly")
End With
' Output each data set to separate worksheet
For Each vItem In oItems
' Convert each data set to array
JSON.ToArray oItems(vItem), aRows, aHeader
' Output array to worksheet
With GetSheet((vItem))
.Cells.Delete
If Transposed Then
Output2DArray .Cells(1, 1), WorksheetFunction.Transpose(aHeader)
Output2DArray .Cells(1, 2), WorksheetFunction.Transpose(aRows)
Else
OutputArray .Cells(1, 1), aHeader
Output2DArray .Cells(2, 1), aRows
End If
.Columns.AutoFit
End With
Next
End Sub
Function GetSheet(sName As String, Optional bCreate = True) As Worksheet
On Error Resume Next
Set GetSheet = ThisWorkbook.Sheets(sName)
If Err Then
If bCreate Then
Set GetSheet = ThisWorkbook.Sheets.Add(, ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
GetSheet.Name = sName
End If
Err.Clear
End If
End Function
Sub OutputArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize(1, UBound(aCells) - LBound(aCells) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
Sub Output2DArray(oDstRng As Range, aCells As Variant)
With oDstRng
.Parent.Select
With .Resize( _
UBound(aCells, 1) - LBound(aCells, 1) + 1, _
UBound(aCells, 2) - LBound(aCells, 2) + 1)
.NumberFormat = "#"
.Value = aCells
End With
End With
End Sub
Finally Sub QuoteDataOutput(vJSON) input is a JSON object, to make it clear how the necessary data is being extracted from it, you may save the JSON string to file, copy the contents and paste it to any JSON viewer for further study. I use online tool http://jsonviewer.stack.hu, target element structure is shown below:
The output for me is as follows (first worksheet shown):
There are 9 main sections, the relevant part of the data is extracted and output to 9 worksheets:
IncomeStatementY
IncomeStatementQ
CashflowY
CashflowQ
BalanceSheetY
BalanceSheetQ
EarningsChartQ
FinancialsChartY
FinancialsChartQ
Having that example you can extract the data you need from that JSON response.

It turns out that Yahoo ended the application from which the web query drew its data. Thank you for all your tips.

run two module at excel start up

I have two modules that i would like to be executed at the open of the workbook what is the best way to do that. below are my module.
module 1
Public Sub workbook_open()
Dim YesOrNoAnswerToMessageBox As String
Dim QuestionToMessageBox As String
QuestionToMessageBox = "Do you Agree?"
YesOrNoAnswerToMessageBox = MsgBox(QuestionToMessageBox, vbYesNo, "Do you agree with disclaimer")
If YesOrNoAnswerToMessageBox = vbNo Then
ActiveWorkbook.Close savechanges:=False
Else
MsgBox "Congratulations!"
End If
End Sub
module 2
Sub workbook_open()
Dim Expired As Date
Expired = "31 March 2016"
If Now() < Expired Then
Sheet1.Visible = True
Sheet2.Visible = True
Sheet3.Visible = True
Sheet6.Visible = True
Sheet7.Visible = True
Sheet8.Visible = True
Sheet9.Visible = True
Sheet13.Visible = True
Sheet5.Visible = True
Sheet10.Visible = xlSheetHidden
End If
If Now() > Expired Then
MsgBox "This file is no longer in use!"
Sheet10.Visible = True
Sheet1.Visible = xlSheetVeryHidden
Sheet2.Visible = xlSheetVeryHidden
Sheet3.Visible = xlSheetVeryHidden
Sheet6.Visible = xlSheetVeryHidden
Sheet7.Visible = xlSheetVeryHidden
Sheet9.Visible = xlSheetVeryHidden
Sheet13.Visible = xlSheetVeryHidden
Sheet5.Visible = xlSheetVeryHidden
Sheet8.Visible = xlSheetVeryHidden
End If
End Sub

The Workbook_Open() event has do be declared in the ThisWorkbook module, not a standard code module.
You can rename your current procedures and just call them both from the open event like so:
In Module1:
Sub Foo()
MsgBox "First Message"
End Sub
In Module2:
Sub Bar()
MsgBox "Second Message"
End Sub
Then in the ThisWorkbook module:
Public Sub Workbook_Open()
Foo
Bar
End Sub
Looking at your existing code, you just need to incorporate the second sub in your If block:
In the ThisWorkbook module:
Public Sub workbook_open()
Dim YesOrNoAnswerToMessageBox As String
Dim QuestionToMessageBox As String
QuestionToMessageBox = "Do you Agree?"
YesOrNoAnswerToMessageBox = MsgBox(QuestionToMessageBox, vbYesNo, "Do you agree with disclaimer")
If YesOrNoAnswerToMessageBox = vbNo Then
ActiveWorkbook.Close savechanges:=False
Else
MsgBox "Congratulations!"
OpeningProcedure '// <~~ Note this, to call the other sub
End If
End Sub
and in Module1:
Sub OpeningProcedure()
Dim Expired As Date Expired = "31 March 2016"
If Now() < Expired Then
Sheet1.Visible = True
Sheet2.Visible = True
Sheet3.Visible = True
Sheet6.Visible = True
Sheet7.Visible = True
Sheet8.Visible = True
Sheet9.Visible = True
Sheet13.Visible = True
Sheet5.Visible = True
Sheet10.Visible = xlSheetHidden
End If
If Now() > Expired Then
MsgBox "This file is no longer in use!"
Sheet10.Visible = True
Sheet1.Visible = xlSheetVeryHidden
Sheet2.Visible = xlSheetVeryHidden
Sheet3.Visible = xlSheetVeryHidden
Sheet6.Visible = xlSheetVeryHidden
Sheet7.Visible = xlSheetVeryHidden
Sheet9.Visible = xlSheetVeryHidden
Sheet13.Visible = xlSheetVeryHidden
Sheet5.Visible = xlSheetVeryHidden
Sheet8.Visible = xlSheetVeryHidden
End If
End Sub

Command Button Code stopped working

I was using this user form code yesterday and everything worked fine. Today, nothing is working. When my command button "Complete" is clicked, the code should verify that the user form is complete (Complete_Enter()) and then transfer the information from the userform to my worksheet. This all worked perfectly yesterday and today it does not. Instead when I click complete, VBA only runs the first line under the Complete_Enter() sub. Here is the code:
Private Sub ConnectorCoverProductionForm_Initialize()
'Empty Serial_NumberTextBox
Serial_Number.Value = ""
Serial_Number.SetFocus
'Empty Order_NumberTextBox
Order_Number.Value = ""
'Empty DateTextBox
TextBox1.Value = ""
Inspector.Clear
Assembler.Clear
Process_Code.Clear
'Uncheck OptionButton
OptionButton1.Value = False
OptionButton2.Value = False
OptionButton3.Value = False
OptionButton4.Value = False
OptionButton5.Value = False
OptionButton6.Value = False
OptionButton21.Value = False
OptionButton12.Value = False
OptionButton13.Value = False
OptionButton14.Value = False
OptionButton15.Value = False
OptionButton16.Value = False
End Sub
Private Sub Assembler_DropButtonClick()
Assembler.List = Array("Trung", "Jesus", "Khoi", "Josie", "Omi")
End Sub
Private Sub ClearALL_Click()
Call ConnectorCoverProductionForm_Initialize
End Sub
Private Sub CommandButton1_Click()
Shell ("Explorer \\PC148\Assembly Group\Traveler
End Sub
Private Sub CommandButton2_Click()
Shell ("Explorer \\PC148\Assembly Group\Traveler
End Sub
Private Sub CommandButton3_Click()
Shell ("Explorer \\PC148\Assembly Group\Traveler Templates\Videos\Edited\Mag
End Sub
Private Sub CommandButton4_Click()
Shell ("Explorer \\PC148\Assembly Group\Traveler Templates\Videos\Edited\Mag
End Sub
Private Sub Complete_Click()
Dim emptyRow As Long
Sheet1.Activate
emptyRow = WorksheetFunction.CountA(Range("C:C")) + 1
Cells(emptyRow, 3).Value = Serial_Number.Value
Cells(emptyRow, 4).Value = Order_Number.Value
Cells(emptyRow, 5).Value = TextBox1.Value
Cells(emptyRow, 6).Value = Revision.Value
Cells(emptyRow, 7).Value = Inspector.Value
Cells(emptyRow, 8).Value = Assembler.Value
Cells(emptyRow, 9).Value = Process_Code.Value
If OptionButton1.Value = True Then Cells(emptyRow, 10).Value = OptionButton1.Caption
If OptionButton21.Value = True Then Cells(emptyRow, 10).Value = OptionButton21.Caption
If OptionButton2.Value = True Then Cells(emptyRow, 11).Value = OptionButton2.Caption
If OptionButton12.Value = True Then Cells(emptyRow, 11).Value = OptionButton12.Caption
If OptionButton3.Value = True Then Cells(emptyRow, 12).Value = OptionButton3.Caption
If OptionButton13.Value = True Then Cells(emptyRow, 12).Value = OptionButton13.Caption
If OptionButton4.Value = True Then Cells(emptyRow, 13).Value = OptionButton4.Caption
If OptionButton14.Value = True Then Cells(emptyRow, 13).Value = OptionButton14.Caption
If OptionButton5.Value = True Then Cells(emptyRow, 14).Value = OptionButton5.Caption
If OptionButton15.Value = True Then Cells(emptyRow, 14).Value = OptionButton15.Caption
If OptionButton6.Value = True Then Cells(emptyRow, 15).Value = OptionButton6.Caption
If OptionButton16.Value = True Then Cells(emptyRow, 15).Value = OptionButton16.Caption
End Sub
Private Sub Complete_Enter()
If Serial_Number.Value = "" Then MsgBox "Fill in Serial Number"
Exit Sub
If Order_Number.Value = "" Then MsgBox "Fill in Order Number"
Exit Sub
If TextBox1.Value = "" Then MsgBox "Fill in Date"
Exit Sub
If Revision.Value = "" Then MsgBox "Select the correct Revision"
Exit Sub
If Inspector.Value = "" Then MsgBox "Who was the inspector? If it was you,select 'SELF'"
Exit Sub
If Assembler.Value = "" Then MsgBox "Select Your Name as the Assembler"
Exit Sub
If Process_Code.Value = "" Then MsgBox "Select the correct Process Code"
Exit Sub
If OptionButton1.Value = False And OptionButton21.Value = False Then MsgBox "What is the Status of Step 1"
Exit Sub
If OptionButton2.Value = False And OptionButton12.Value = False Then MsgBox "What is the Status of Step 2"
Exit Sub
If OptionButton3.Value = False And OptionButton13.Value = False Then MsgBox "What is the Status of Step 3"
Exit Sub
If OptionButton4.Value = False And OptionButton14.Value = False Then MsgBox "What is the Status of Step 4"
Exit Sub
If OptionButton5.Value = False And OptionButton15.Value = False Then MsgBox "What is the Status of Step 5"
Exit Sub
If OptionButton6.Value = False And OptionButton16.Value = False Then MsgBox "What is the Status of Step 6"
Exit Sub
End Sub
Private Sub Inspector_DropButtonClick()
Inspector.List = Array("Tom", "Tre", "Omi", "Self")
End Sub
Private Sub Process_Code_DropButtonClick()
Process_Code.List = [index(12*(row(1:12)-1),)]
End Sub
Private Sub Revision_DropButtonClick()
Revision.List = [index(char(64+row(1:26)),)]
End Sub

I expect your routine should be modified like so:
Private Sub Complete_Enter()
If Serial_Number.Value = "" Then
MsgBox "Fill in Serial Number"
ElseIf Order_Number.Value = "" Then
MsgBox "Fill in Order Number"
ElseIf TextBox1.Value = "" Then
MsgBox "Fill in Date"
ElseIf Revision.Value = "" Then
MsgBox "Select the correct Revision"
ElseIf Inspector.Value = "" Then
MsgBox "Who was the inspector? If it was you,select 'SELF'"
ElseIf Assembler.Value = "" Then
MsgBox "Select Your Name as the Assembler"
ElseIf Process_Code.Value = "" Then
MsgBox "Select the correct Process Code"
ElseIf OptionButton1.Value = False And OptionButton21.Value = False Then
MsgBox "What is the Status of Step 1"
ElseIf OptionButton2.Value = False And OptionButton12.Value = False Then
MsgBox "What is the Status of Step 2"
ElseIf OptionButton3.Value = False And OptionButton13.Value = False Then
MsgBox "What is the Status of Step 3"
ElseIf OptionButton4.Value = False And OptionButton14.Value = False Then
MsgBox "What is the Status of Step 4"
ElseIf OptionButton5.Value = False And OptionButton15.Value = False Then
MsgBox "What is the Status of Step 5"
ElseIf OptionButton6.Value = False And OptionButton16.Value = False Then
MsgBox "What is the Status of Step 6"
End If
End Sub

Adding Validation List with VBA is unstable

In SetWS sheet I have the following code in Worksheet_Deactivate:
Private Sub Worksheet_Deactivate()
Dim ActWS, SetWS As Worksheet
Set ActWS = ActiveWorkbook.Sheets("Activity_Plan")
Set SetWS = ActiveWorkbook.Sheets("Settings")
With ActWS.Range("J11:J20").Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="=Settings!$AS$10:$AS$20" '
.IgnoreBlank = True
.InCellDropdown = True
End With '
End Sub
In RepWS sheet (where I only create a couple of graphs) I have the following code in Worksheet_Activate:
Private Sub Worksheet_Activate()
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim ScopeWS, RepWS, ActWS, SetWS As Worksheet
Set ScopeWS = ActiveWorkbook.Sheets("Scope")
Set RepWS = ActiveWorkbook.Sheets("Rep")
Set ActWS = ActiveWorkbook.Sheets("Activity_Plan")
Set SetWS = ActiveWorkbook.Sheets("Settings")
LRowScopeE = ScopeWS.Range("E" & Rows.Count).End(xlUp).Row
If SetWS.Range("W17") > SetWS.Range("W18") Then '
MsgBox ("bla bla")
Exit Sub
End If
RepWS.ChartObjects("Diagramm 3").Activate
ActiveChart.SeriesCollection(1).Name = "=Scope!$M$4"
ActiveChart.SeriesCollection(1).Values = "=Scope!$M$11:$M$" & LRowScopeE
ActiveChart.SeriesCollection(1).XValues = "=Scope!$E$11:$E$" & LRowScopeE
ActiveChart.SeriesCollection(2).Name = "=Scope!$P$4"
ActiveChart.SeriesCollection(2).Values = "=Scope!$P$11:$P$" & LRowScopeE
ActiveChart.SeriesCollection(3).Name = "=Scope!$U$4"
ActiveChart.SeriesCollection(3).Values = "=Scope!$T$11:$T$" & LRowScopeE
ActiveChart.Axes(xlValue).MaximumScaleIsAuto = True
ActiveChart.Axes(xlValue).TickLabels.NumberFormat = "#.##0 €"
ActiveChart.FullSeriesCollection(1).DataLabels.NumberFormat = "#.##0 €"
ActiveSheet.ChartObjects("Diagramm 14").Activate
ActiveChart.SeriesCollection(1).Name = "=Settings!$CJ$10"
ActiveChart.SeriesCollection(1).Values = "=Settings!$CJ$11:$CJ$" & SetWS.Range("CL8").Value
ActiveChart.SeriesCollection(1).XValues = "=Settings!$CI$11:$CI$" & SetWS.Range("CL8").Value
ActiveChart.SeriesCollection(2).Name = "=Settings!$CK$10"
ActiveChart.SeriesCollection(2).Values = "=Settings!$CK$11:$CK$" & SetWS.Range("CL8").Value
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
When I switch from SetWS to RepWS, it throws an error
"Application defined or object defined error"
and highlights in SetWS the following:
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
Operator:=xlBetween, Formula1:="=Settings!$AS$10:$AS$20"
Switching between any other pair of sheets in this file does not cause this error (e.g. switching SetWS to any other sheet is OK).
UPDATE: I notice I more thing - As soon as I activate RepWS once, any further attempt to switch from SetWS to RepWS throws an error. Something is wrong with RepWS code...

Avoid the use of Active(Workbook/Sheet/Cell/Chart/...), the .Activate/.Select method and the .Selection property.
your worksheet_activate sub, might look something like this
Private Sub Worksheet_Activate()
Dim ScopeWS, RepWS, ActWS, SetWS As Worksheet
With Application
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
With ThisWorkbook
Set ScopeWS = .Sheets("Scope")
Set RepWS = .Sheets("Rep")
Set ActWS = .Sheets("Activity_Plan")
Set SetWS = .Sheets("Settings")
End With
LRowScopeE = ScopeWS.Range("E" & Rows.Count).End(xlUp).Row
If SetWS.Range("W17") > SetWS.Range("W18") Then '
MsgBox ("bla bla")
Else
With RepWS
'Diagram 3
With .ChartObjects("Diagram 3").Chart
'Series 1
With .SeriesCollection(1)
.Name = "=Scope!$M$4"
.Values = "=Scope!$M$11:$M$" & LRowSco
.XValues = "=Scope!$E$11:$E$" & LRowScopeE
End With
'Series 2
With .SeriesCollection(2)
.Name = "=Scope!$P$4"
.Values = "=Scope!$P$11:$P$" & LRowScopeE
End With
'Series 3
With .seriescolection(3)
.Name = "=Scope!$U$4"
.Values = "=Scope!$T$11:$T$" & LRowScopeE
End With
'Layout
With .Axes(xlValue)
.MaximumScaleIsAuto = True
.TickLabels.NumberFormat = "#.##0 €"
End With
.FullSeriesCollection(1).DataLabels.NumberFormat = "#.##0 €"
End With
'Diagram 14
With .ChartObjects("Diagram 14").Chart
'Series 1
With .SeriesCollection(1)
.Name = "=Settings!$CJ$10"
.Values = "=Settings!$CJ$11:$CJ$" & SetWS.Range("CL8").Value
.XValues = "=Settings!$CI$11:$CI$" & SetWS.Range("CL8").Value
End With
'Series 2
With .SeriesCollection(2)
.Name = "=Settings!$CK$10"
.Values = "=Settings!$CK$11:$CK$" & SetWS.Range("CL8").Value
End With
End With
End With
End If
With Application
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub

Formatting specific part of text string in VBA

I am in process of creating a macro that will save the current workbook, create a new outlook message and attach the file to the message. My macro does that but I can not format the text in the body of the email to my liking.
Dim OutApp As Object
Dim OutMail As Object
Dim sBody, Customer As String
ActiveWorkbook.Save
sBody = "All," & Chr(10) & Chr(10) & "Please Approve attached Request below for " & rType & "." _
& Chr(10) & Chr(10) & "Customer: " & customer & Chr(10)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = recip
.CC = CCed
.BCC = ""
.subject = subject
.Body = sBody
.Attachments.Add ActiveWorkbook.FullName
.display
End With
On Error GoTo 0
End Sub
I want the following message to be displayed (with the format) in the email.
All,
Please Approve attached Request below for "rtype".
Customer: Stackoverflow
So, the word "customer" needs to be bold. I have tired multiple solutions but they do not work as this is creating an outlook mail object.
Any Help will be appreciated.
**
Solution: To make the HTML tags work change the body type to html by
".HTMLBody". and you will be able to use HTML Tags. Kudos to Dick
Kusleika
**

HTML tags do work. I don't know why you say they don't.
sBody = "All,<br /><br />Please Approve attached request for " & rType & ".<br /><br /><strong>Customer:</strong> " & customer & "<br />"
then instead of the .Body property, use .HTMLBody
.HTMLBody = sBody

you have a few options
1)use HTML like a few people have commented
2)put that text on a hidden sheet and format it as required then ref it to the body as a range e.g. .Body = sheets("hidden_Body").range("A1:B10")
3)of you can try using something like below (please note below is used for adding one wingding character into a string and would need to be modified to fit your purpose)
Sub Build_Wingdings(Sh As Worksheet, rng As Range)
Dim cur_L As Integer
cur_L = 1
Sheets("Word_Specifications").Range("BZ9").Copy
Sh.Range(rng.Address).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
With Sheets("Word_Specifications")
.Select
For Each cell In .Range(.Range("Word_Standard_Start").Address, .Range("Word_Standard_Start").End(xlDown).Address)
If cell.value = "" Then
Else
L = Len(cell.value) + 1
With Sh.Range(rng.Address)
With .Characters(start:=cur_L, Length:=L).Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 9
.Bold = False
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
cur_L = cur_L + L
If .value <> "" Then
add_Wingdings cur_L, 1, Sh, rng
cur_L = cur_L + 2
End If
End With
End If
Next
End With
End Sub
Sub add_Wingdings(start As Integer, Length As Integer, Sh As Worksheet, rng As Range)
With Sh.Range(rng.Address).Characters(start:=start, Length:=Length).Font
.Name = "Wingdings 3"
.FontStyle = "Regular"
.Size = 9
.Bold = False
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
End Sub