I have multiple subs within VBA that all have their output within the same text box (WarningData) in a PPT slide. For example, Sub 1 takes a user selection (a selection they made from a drop down menu within a GUI) and inserts that at the top of the text box. Sub 2 inserts another line of text below that line. Sub 3 inserts additional text below that. I need Sub 1 and 2 to have the same font style, but Sub 3 needs to have a different font.
Here is what Sub 1 and Sub 2 look like:
Private Sub 1() 'Sub 2 is very similar.
Call Dictionary.WindInfo
'Sets the font for the warning information text.
With ActiveWindow.Selection.SlideRange.Shapes("WarningData").TextFrame2.TextRange.Font
.Size = 24
.Name = "Calibri"
.Bold = msoTrue
.Shadow.Visible = True
.Glow.Radius = 10
.Glow.Color = RGB(128, 0, 0)
End With
ComboBoxList = Array(CStr(ComboBox3), CStr(ComboBox4))
For Each Ky In ComboBoxList
On Error Resume Next
'If nothing is selected in ComboBox4, do nothing and exit this sub.
If ComboBox4 = "" Then
Exit Sub
ElseIf ComboBox3 = "" Then
ActiveWindow.Selection.SlideRange.Shapes("WarningData").TextFrame2.TextRange = _
ActiveWindow.Selection.SlideRange.Shapes("WarningData").TextFrame2.TextRange & dict3.Item(Ky)(0)
'Otherwise, if it has a selection, insert selected text.
ElseIf ComboBox3 <> "" Then
ActiveWindow.Selection.SlideRange.Shapes("WarningData").TextFrame2.TextRange = _
ActiveWindow.Selection.SlideRange.Shapes("WarningData").TextFrame2.TextRange & vbCrLf & vbCrLf & dict3.Item(Ky)(0)
End If
Next
Set dict3 = Nothing
End Sub
The following sub is the one that I need to have a different font style:
Private Sub 3()
Call Dictionary.Call2Action
ComboBoxList = Array(CStr(ComboBox7))
For Each Ky In ComboBoxList
On Error Resume Next
'If nothing is selected in ComboBox7 and TextBox9, do nothing and exit this sub.
If ComboBox7 = "" And TextBox9 = "" Then
Exit Sub
'Otherwise, if either has a selection, insert selected text.
ElseIf ComboBox7 <> "" And TextBox9 = "" Then
ActiveWindow.Selection.SlideRange.Shapes("WarningData").TextFrame2.TextRange = _
ActiveWindow.Selection.SlideRange.Shapes("WarningData").TextFrame2.TextRange & vbCrLf & vbCrLf & dict7.Item(Ky)(0)
ElseIf ComboBox7 = "" And TextBox9 <> "" Then
ActiveWindow.Selection.SlideRange.Shapes("WarningData").TextFrame2.TextRange = _
ActiveWindow.Selection.SlideRange.Shapes("WarningData").TextFrame2.TextRange & vbCrLf & vbCrLf & TextBox9
End If
Next
Set dict7 = Nothing
End Sub
Any idea if this is possible?
Thanks!!
I simplified the code using a With statement and added 2 x font lines to show how to set the Font name. Other properties are also available in the Font2 object e.g. .Size, .Bold, .Fill etc.
Private Sub Three()
Call Dictionary.Call2Action
ComboBoxList = Array(CStr(ComboBox7))
For Each Ky In ComboBoxList
On Error Resume Next
With ActiveWindow.Selection.SlideRange.Shapes("WarningData").TextFrame2
'If nothing is selected in ComboBox7 and TextBox9, do nothing and exit this sub.
If ComboBox7 = "" And TextBox9 = "" Then
Exit Sub
'Otherwise, if either has a selection, insert selected text.
ElseIf ComboBox7 <> "" And TextBox9 = "" Then
.TextRange = .TextRange & vbCrLf & vbCrLf & dict7.Item(Ky)(0)
.TextRange.Font.Name = "Calibri"
ElseIf ComboBox7 = "" And TextBox9 <> "" Then
.TextRange = .TextRange & vbCrLf & vbCrLf & TextBox9
.TextRange.Font.Name = "Calibri"
End If
End With
Next
Set dict7 = Nothing
End Sub
Using the TextRange.Paragraphs method I was able to accomplish this task:
Private Sub 3()
Call Dictionary.Call2Action
ComboBoxList = Array(CStr(ComboBox7))
For Each Ky In ComboBoxList
On Error Resume Next
With ActiveWindow.Selection.SlideRange.Shapes("WarningData").TextFrame2
'If nothing is selected in ComboBox7 and TextBox9, do nothing and exit this sub.
If ComboBox7 = "" And TextBox9 = "" Then
Exit Sub
'Otherwise, if either has a selection, insert selected text.
ElseIf ComboBox7 <> "" And TextBox9 = "" Then
.TextRange = .TextRange & vbCrLf & vbCrLf & dict7.Item(Ky)(0)
.TextRange.Paragraphs(3).Font.Size = 18
.TextRange.Paragraphs(3).Font.Name = "Calibri"
.TextRange.Paragraphs(3).Font.Fill.ForeColor.RGB = vbWhite
.TextRange.Paragraphs(3).Font.Bold = msoTrue
.TextRange.Paragraphs(3).Font.Glow.Transparency = 1
ElseIf ComboBox7 = "" And TextBox9 <> "" Then
.TextRange = .TextRange & vbCrLf & vbCrLf & TextBox9
.TextRange.Paragraphs(3).Font.Size = 18
.TextRange.Paragraphs(3).Font.Name = "Calibri"
.TextRange.Paragraphs(3).Font.Fill.ForeColor.RGB = vbWhite
.TextRange.Paragraphs(3).Font.Bold = msoTrue
End If
End With
Next
Set dict7 = Nothing
End Sub
Related
I am a beginner in Excel VBA but I would like to create a file where I can select certain worksheets by means of a userform with checkboxes. In principle, it is then intended that only the check boxes where the value is true should be exported.
Below I have 2 codes that work well separately from each other but I have not yet been able to get them to work together.
Note: both codes come from the internet.
If possible I would like to write a loop to keep the overview.
the code to export sheets as pdf and put them in a outlook
Sub Saveaspdfandsend1()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xArrShetts As Variant
Dim xPDFNameAddress As String
Dim xStr As String
xArrShetts = Array("test", "Sheet1", "Sheet2") 'Enter the sheet names you will send as pdf files enclosed with quotation marks and separate them with comma. Make sure there is no special characters such as \/:"*<>| in the file name.
For I = 0 To UBound(xArrShetts)
On Error Resume Next
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
If xSht.Name <> xArrShetts(I) Then
MsgBox "Worksheet no found, exit operation:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "Kutools for Excel"
Exit Sub
End If
Next
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
'Check if file already exist
xYesorNo = MsgBox("If same name files exist in the destination folder, number suffix will be added to the file name automatically to distinguish the duplicates" & vbCrLf & vbCrLf & "Click Yes to continue, click No to cancel", _
vbYesNo + vbQuestion, "File Exists")
If xYesorNo <> vbYes Then Exit Sub
For I = 0 To UBound(xArrShetts)
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
xStr = xFolder & "\" & xSht.Name & ".pdf"
xNum = 1
While Not (Dir(xStr, vbDirectory) = vbNullString)
xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
xNum = xNum + 1
Wend
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard
Else
End If
xArrShetts(I) = xStr
Next
'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.CC = ""
.Subject = "????"
For I = 0 To UBound(xArrShetts)
.Attachments.Add xArrShetts(I)
Next
If DisplayEmail = False Then
'.Send
End If
End With
End Sub
the other code i tried I can see which checkbox is checked unfortunately I can't rewrite it so only the checked boxes will be exported to pdf.
Private Sub CommandButton100_Click()
For i = 100 To 113
If UserForm2.Controls("CheckBox" & i).Value = True Then
a = a + 1
End If
Next i
k = 1
For i = 100 To 113
If UserForm2.Controls("CheckBox" & i).Value = True And a = 1 Then
b = UserForm2.Controls("CheckBox" & i).Caption & "."
ElseIf UserForm2.Controls("CheckBox" & i).Value = True And k <> a Then
b = b & UserForm2.Controls("CheckBox" & i).Caption & ", "
k = k + 1
ElseIf UserForm2.Controls("CheckBox" & i).Value = True And k = a Then
b = b & "and " & UserForm2.Controls("CheckBox" & i).Caption & "."
End If
Next i
MsgBox ("You have selected " & b)
End Sub
Can someone help me please I am struggling for some time now?
Please, try the next function:
Private Function sheetsArr(uF As UserForm) As Variant
Dim c As MSForms.Control, strCBX As String, arrSh
For Each c In uF.Controls
If TypeOf c Is MSForms.CheckBox Then
If c.value = True Then strCBX = strCBX & "," & c.Caption
End If
Next
sheetsArr = Split(Mid(strCBX, 2), ",") 'Mid(strCBX, 2) eliminates the first string character (",")
End Function
It will return an array composed from the ticked check boxes caption.
It can be used demonstratively, in this way:
Sub testSheetsArrFunction()
Debug.Print Join(sheetsArr(UserForm2), ",")
End Sub
The above code will return in Immediate Window a string containing the checked check boxes caption (separated by comma). It may be run from a standard module, too. Of course, the function must be copied in that module. And the form to be loaded, having some check boxes ticked.
Now, you have to change a single code line in your (working) code:
Replace:
xArrShetts = Array("test", "Sheet1", "Sheet2")
with:
xArrShetts = sheetsArr(UserForm2)
It should use the array built in the above function. Of course the function have to be copied in the module where to be called. If placed in the form code module, it can be simple called as:
xArrShetts = sheetsArr(Me)
Edited:
You should only paste the next code in the form code module and show the form:
Private Sub CommandButton1_Click()
Dim xSht As Worksheet
Dim xFileDlg As FileDialog
Dim xFolder As String
Dim xYesorNo, I, xNum As Integer
Dim xOutlookObj As Object
Dim xEmailObj As Object
Dim xUsedRng As Range
Dim xArrShetts As Variant
Dim xPDFNameAddress As String
Dim xStr As String
'xArrShetts = Array("test", "Sheet1", "Sheet2") 'Enter the sheet names you will send as pdf files enclosed with quotation marks and separate them with comma. Make sure there is no special characters such as \/:"*<>| in the file name.
xArrShetts = sheetsArr(Me)
For I = 0 To UBound(xArrShetts)
On Error Resume Next
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
If xSht.Name <> xArrShetts(I) Then
MsgBox "Worksheet no found, exit operation:" & vbCrLf & vbCrLf & xArrShetts(I), vbInformation, "Kutools for Excel"
Exit Sub
End If
Next
Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
If xFileDlg.Show = True Then
xFolder = xFileDlg.SelectedItems(1)
Else
MsgBox "You must specify a folder to save the PDF into." & vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Must Specify Destination Folder"
Exit Sub
End If
'Check if file already exist
xYesorNo = MsgBox("If same name files exist in the destination folder, number suffix will be added to the file name automatically to distinguish the duplicates" & vbCrLf & vbCrLf & "Click Yes to continue, click No to cancel", _
vbYesNo + vbQuestion, "File Exists")
If xYesorNo <> vbYes Then Exit Sub
For I = 0 To UBound(xArrShetts)
Set xSht = Application.ActiveWorkbook.Worksheets(xArrShetts(I))
xStr = xFolder & "\" & xSht.Name & ".pdf"
xNum = 1
While Not (Dir(xStr, vbDirectory) = vbNullString)
xStr = xFolder & "\" & xSht.Name & "_" & xNum & ".pdf"
xNum = xNum + 1
Wend
Set xUsedRng = xSht.UsedRange
If Application.WorksheetFunction.CountA(xUsedRng.Cells) <> 0 Then
xSht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=xStr, Quality:=xlQualityStandard
End If
xArrShetts(I) = xStr
Next
'Create Outlook email
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = ""
.CC = ""
.Subject = "????"
For I = 0 To UBound(xArrShetts)
.Attachments.Add xArrShetts(I)
Next
If DisplayEmail = False Then
'.Send
End If
End With
End Sub
Private Function sheetsArr(uF As UserForm) As Variant
Dim c As MSForms.Control, strCBX As String, arrSh
For Each c In uF.Controls
If TypeOf c Is MSForms.CheckBox Then
If c.Value = True Then strCBX = strCBX & "," & c.Caption
End If
Next
sheetsArr = Split(Mid(strCBX, 2), ",") 'Mid(strCBX, 2) eliminates the first string character (",")
End Function
I can not get a negative answer if the style is not in the style list
Example:
If Styles("FirstLine").BuiltIn = False Then
Application.ActiveDocument.Styles.Add(Name:="FirstLine", Type:=wdStyleTypeParagraph)
Application.ActiveDocument.Styles("FirstLine").AutomaticallyUpdate = False
With Application.ActiveDocument.Styles("FirstLine").Frame
.TextWrap = True
.HorizontalPosition = wdFrameRight
.HorizontalDistanceFromText = 4
.LockAnchor = False
End With
End If
And he returns the answer:
System.Runtime.InteropServices.COMException: 'The requested member of
the collection does not exist.'
How can I get a negative answer?
Here are the solutions in both VB.NET & VBA to check if a style exists in Word before adding it.
VB.NET
Public Sub AddNewStyle(ByVal styleName As String)
Try
'---------------------------------------------------------------------------------------------------
' Purpose: Create a new style in Microsoft Word
' Example: AddNewStyle("YourNewStyleNameHere")
' AddNewStyle("Medium Grid 3 - Accent 4") 'a default style from Microsoft Word 2016
'---------------------------------------------------------------------------------------------------
Dim MyDocument As Word.Document = Globals.ThisAddIn.Application.ActiveDocument
Dim styleExist As Boolean = False
Dim style As Word.Style
For Each style In Globals.ThisAddIn.Application.ActiveDocument.Styles
If styleName = style.NameLocal Then
styleExist = True
Exit For
End If
Next style
If Not styleExist Then
Dim MyStyle As Word.Style = MyDocument.Styles.Add(styleName, Word.WdStyleType.wdStyleTypeParagraph)
MyDocument.Styles(styleName).AutomaticallyUpdate = False
With MyDocument.Styles(styleName).Frame
.TextWrap = True
.HorizontalPosition = Word.WdFramePosition.wdFrameRight
.HorizontalDistanceFromText = 4
.LockAnchor = False
End With
End If
Catch ex As Exception
MsgBox("Contact your system administrator." + Environment.NewLine + "Description: " + ex.ToString(), vbOK + vbExclamation, "Unexpected Error")
End Try
End Sub
VBA
Public Sub AddNewStyle(ByVal styleName As String)
'---------------------------------------------------------------------------------------------------
' Purpose: Create a new style in Microsoft Word
' Example: AddNewStyle "YourNewStyleNameHere"
' AddNewStyle "Medium Grid 3 - Accent 4" 'a default style from Microsoft Word 2016
'---------------------------------------------------------------------------------------------------
Dim MyStyle As Word.Style
Dim msg As String
On Error Resume Next
Set MyStyle = ActiveDocument.Styles(styleName)
On Error GoTo ErrTrap
If Not MyStyle Is Nothing Then
Set MyStyle = Application.ActiveDocument.Styles.Add(styleName, wdStyleTypeParagraph)
Application.ActiveDocument.Styles(styleName).AutomaticallyUpdate = False
With Application.ActiveDocument.Styles(styleName).Frame
.TextWrap = True
.HorizontalPosition = wdFrameRight
.HorizontalDistanceFromText = 4
.LockAnchor = False
End With
End If
ExitProcedure:
On Error Resume Next
Set MyStyle = Nothing
Exit Sub
ErrTrap:
Select Case Err.Number
Case Is <> 0
msg = "Contact your system administrator."
msg = msg & vbCrLf & "Procedure: AddNewStyle"
msg = msg & IIf(Line = 0, "", vbCrLf & "Error Line: " & Erl)
msg = msg & vbCrLf & "Error #: " & Err.Number
msg = msg & vbCrLf & "Error Description: " & Err.Description
MsgBox msg, vbCritical, "Unexpected Error"
Resume ExitProcedure
Case Else
Resume ExitProcedure
End Select
End Sub
I have a page in my workbook where certain cells are multi-select. Users can choose values from a dropdown list and it will append them and format them to be uploaded into our system. It works great -- but there's just one problem. There's no way to remove a single value currently. If a user selects the wrong value from the dropdown, they'd have to delete and start over. Is there a way to remove individual values? Here's the current multi-select code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngDV As Range
Dim oldVal As String
Dim newVal As String
Dim strSep As String
Dim strSep2 As String
Dim header As String
Dim MatchField As Range
Dim AnsType As Range
Application.ScreenUpdating = False
strSep = Chr(34) & "," & Chr(34)
strSep2 = "," & Chr(34)
header = Me.Cells(11, Target.Column).Value
Set MatchField = ThisWorkbook.Worksheets("User Fields").Range("B16:B100").Find(header)
If Not MatchField Is Nothing Then
Set AnsType = MatchField.Offset(0, 2)
End If
Application.EnableEvents = False
On Error Resume Next
If Target.Count > 1 Then GoTo exitHandler
Set rngDV = Cells.SpecialCells(xlCellTypeAllValidation)
On Error GoTo exitHandler
If rngDV Is Nothing Then GoTo exitHandler
If Intersect(Target, rngDV) Is Nothing Then
'do nothing
Else 'cell has data validation
If InStr(1, AnsType, "Multiple") > 0 Then 'Determines if current column corresponds to a multi-select field
newVal = Target.Value
Application.Undo
oldVal = Target.Value
Target.Value = newVal
If newVal = "" Then
'do nothing
Else
If oldVal = "" Then
Target.Value = newVal
ElseIf InStr(1, oldVal, newVal) = 0 Then
If InStr(1, oldVal, Chr(34)) > 0 Then
Target.Value = oldVal & strSep2 & newVal & Chr(34)
Else
Target.Value = Chr(34) & oldVal & strSep & newVal & Chr(34)
End If
Else
Target.Value = oldVal
End If
End If
End If
End If
Application.ScreenUpdating = True
exitHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
You need to remove the "If" statement that prohibits doubles of the same item to be able to delete it from the string. Try the following code, leaving the doubles statement commented out.
Private Sub Worksheet_Change(ByVal Target As Range)
'Updated: 2016/4/12
Dim xRng As Range
Dim xValue1 As String
Dim xValue2 As String
If Target.Count > 1 Then Exit Sub
On Error Resume Next
Set xRng = Cells.SpecialCells(xlCellTypeAllValidation)
If xRng Is Nothing Then Exit Sub
Application.EnableEvents = False
If Not Application.Intersect(Target, xRng) Is Nothing Then
xValue2 = Target.Value
Application.Undo
xValue1 = Target.Value
Target.Value = xValue2
If xValue1 <> "" Then
If xValue2 <> "" Then
' If xValue1 = xValue2 Or _
' InStr(1, xValue1, ", " & xValue2) Or _
InStr(1, xValue1, xValue2 & ",") Then
If InStr(1, xValue1, xValue2 & ",") > 0 Then
xValue1 = Replace(xValue1, xValue2 & ", ", "") ' If it's in the middle with comma
Target.Value = xValue1
GoTo jumpOut
End If
If InStr(1, xValue1, ", " & xValue2) > 0 Then
xValue1 = Replace(xValue1, ", " & xValue2, "") ' If it's at the end with a comma in front of it
Target.Value = xValue1
GoTo jumpOut
End If
If xValue1 = xValue2 Then ' If it is the only item in string
xValue1 = ""
Target.Value = xValue1
GoTo jumpOut
End If
Target.Value = xValue1 & ", " & xValue2
End If
jumpOut:
End If
End If
Application.EnableEvents = True
End Sub
I had a few issues with John's answer, where values like "707" and "7" would cause problems. Here's the script I ended up using. Note that the implementation of the first part is a bit different too.
Private Sub Worksheet_Change(ByVal Target As Range)
'Code by Sumit Bansal from https://trumpexcel.com
' To allow multiple selections in a Drop Down List in Excel (without repetition)
Application.EnableEvents = True
On Error GoTo Exitsub
If Target.Column = 9 Then
If Target.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
GoTo Exitsub
ElseIf Target.Value = "" Then
GoTo Exitsub
Else
Application.EnableEvents = False
Newvalue = Target.Value
Application.Undo
Oldvalue = Target.Value
Target.Value = Newvalue
If Oldvalue <> "" Then
If Newvalue <> "" Then
If InStr(1, Oldvalue, ", " & Newvalue & ",") > 0 Then
Oldvalue = Replace(Oldvalue, Newvalue & ", ", "") ' If it's in the middle with comma
Target.Value = Oldvalue
GoTo jumpOut
End If
If Left(Oldvalue, Len(Newvalue & ", ")) = Newvalue & ", " Then
Oldvalue = Replace(Oldvalue, Newvalue & ", ", "") ' If it's at the start with comma
Target.Value = Oldvalue
GoTo jumpOut
End If
If Right(Oldvalue, Len(", " & Newvalue)) = ", " & Newvalue Then
Oldvalue = Left(Oldvalue, Len(Oldvalue) - Len(", " & Newvalue)) ' If it's at the end with a comma in front of it
Target.Value = Oldvalue
GoTo jumpOut
End If
If Oldvalue = Newvalue Then ' If it is the only item in string
Oldvalue = ""
Target.Value = Oldvalue
GoTo jumpOut
End If
Target.Value = Oldvalue & ", " & Newvalue
End If
jumpOut:
End If
End If
End If
Application.EnableEvents = True
Exitsub:
Application.EnableEvents = True
End Sub
I want the entire Private Sub to Exit if the Copier routine is exited. So the DoDays routines is never called.
Sub Copier()
Dim x As String
Dim z As Integer
x = InputBox("Enter Number of Days in Month")
If x = "" Then
MsgBox "User Pressed Cancel!" & vbCrLf & _
"or did not enter a value!", vbOKOnly + vbInformation, _
"Inputbox Result:"
z = 10
Exit Sub
ElseIf CInt(x) = 0 Then
MsgBox "User Pressed Cancel!" & vbCrLf & _
"or did not enter a value!", vbOKOnly + vbInformation, _
"Inputbox Result:"
z = 10
Exit Sub
Else: End If
y = CInt(x) - 1
For numtimes = 1 To y
ActiveWorkbook.Sheets("Sheet1").Copy _
after:=ActiveWorkbook.Sheets("Sheet1")
Next
DoDays
End Sub
Private Sub COPY_NUMBER_Click()
COPY_NUMBER.BackColor = 12713921
Copier
' DoDays
COPY_NUMBER.BackColor = 12500670
COPY_NUMBER.Enabled = False
End Sub
The call to the DoDays in the Copier sub doesn't seem to work because I literally need to exit the Private Sub so the button remains enabled.
I would merge the Copier procedure into the COPY_NUMBER_Click event procedure:
Private Sub COPY_NUMBER_Click()
COPY_NUMBER.BackColor = 12713921
Dim x As String
x = InputBox("Enter Number of Days in Month")
If x = "" Then
MsgBox "User Pressed Cancel!" & vbCrLf & _
"or did not enter a value!", vbOKOnly + vbInformation, _
"Inputbox Result:"
Exit Sub
ElseIf CInt(x) = 0 Then
MsgBox "User Pressed Cancel!" & vbCrLf & _
"or did not enter a value!", vbOKOnly + vbInformation, _
"Inputbox Result:"
Exit Sub
End If
y = CInt(x) - 1
For numtimes = 1 To y
ActiveWorkbook.Sheets("Sheet1").Copy _
After:=ActiveWorkbook.Sheets("Sheet1")
Next
DoDays
COPY_NUMBER.BackColor = 12500670
COPY_NUMBER.Enabled = False
End Sub
Create a global variable and update it at the end of your Copier method then check it before DoDays is called
Private bRunDoDays As Boolean
Sub Copier()
'set to false
bRunDoDays = False
Dim x As String
Dim z As Integer
x = InputBox("Enter Number of Days in Month")
If x = "" Then
MsgBox "User Pressed Cancel!" & vbCrLf & _
"or did not enter a value!", vbOKOnly + vbInformation, _
"Inputbox Result:"
z = 10
Exit Sub
ElseIf CInt(x) = 0 Then
MsgBox "User Pressed Cancel!" & vbCrLf & _
"or did not enter a value!", vbOKOnly + vbInformation, _
"Inputbox Result:"
z = 10
Exit Sub
Else: End If
y = CInt(x) - 1
For numtimes = 1 To y
ActiveWorkbook.Sheets("Sheet1").Copy _
after:=ActiveWorkbook.Sheets("Sheet1")
Next
'set to true
bRunDoDays = True
End Sub
Private Sub COPY_NUMBER_Click()
COPY_NUMBER.BackColor = 12713921
Copier
If bRunDoDays = False Then Exit Sub
DoDays
COPY_NUMBER.BackColor = 12500670
COPY_NUMBER.Enabled = False
End Sub
You can change Copier to a Boolean Function and edit the call to test whether it executed successfully.
Your call would look like:
If Not Copier Then Exit Sub
Your Copier Function would look like:
Public Function Copier() As Boolean
'Does Stuff
Copier = True
End Function
Make sure you have Option Explicit enabled. It should have thrown a compile error on the If z = 10 Then Exit Sub since it is out of scope.
I have a textbox set up in a GUI where the user can enter information. This string is then spit out in a textbox within a PPT slide. Depending on the number of lines used in the textbox within the PPT slide, I need to enter the next set of information so many new lines below the text from the textbox. Here is what I have so far:
This is the code that takes the text the user enters in the textbox within the GUI and places it in the textbox within the PPT slide:
Private Sub Location()
With ActiveWindow.Selection.SlideRange.Shapes("WarningData").TextFrame2
'Make sure there is text in the call to action textbox. If not, display an error message.
If C2AText = "" Then
MsgBox "Woah there! You need to enter text in the location/call to action box."
'Otherwise, if text is inserted, place that text in the WarningData box found on the PPT slide.
Else
.TextRange = C2AText
.TextRange.Paragraphs.Font.Size = 21
.TextRange.Paragraphs.Font.Name = "Calibri"
.TextRange.Paragraphs.Font.Shadow.Visible = True
.TextRange.Paragraphs.Font.Bold = msoTrue
End If
End With
End Sub
This text determines whether or not anything is selected in the HailInfo drop down. If it is, I need to place this text so many lines below the C2AText that was inserted in the previous Sub:
Private Sub HailInfo()
Call Dictionary.HailInfo
ComboBoxList = Array(CStr(HailDropDown))
For Each Ky In ComboBoxList
'On Error Resume Next
With ActiveWindow.Selection.SlideRange.Shapes("WarningData").TextFrame2
'If nothing is selected in HailDropDown, do nothing and exit this sub.
If HailDropDown = "" Then
Exit Sub
'If a hail option is selected, execute the following code.
ElseIf HailDropDown <> "" And C2AText.LineCount = 2 Then
.TextRange = .TextRange & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & dict2.Item(Ky)(0)
ElseIf HailDropDown <> "" And C2AText.LineCount = 3 Then
.TextRange = .TextRange & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & dict2.Item(Ky)(0)
End If
End With
Next
Set dict2 = Nothing
End Sub
Using the C2AText.LineCount within the HailInfo sub does not appear to do anything. It will not insert the hail text anywhere, so I am not sure what I am doing wrong. Any help would be greatly appreciated...thanks!!
You should try the following ...
Private Sub HailInfo()
Call Dictionary.HailInfo
ComboBoxList = Array(CStr(HailDropDown))
For Each Ky In ComboBoxList
'On Error Resume Next
With ActiveWindow.Selection.SlideRange.Shapes("WarningData").TextFrame2
'If nothing is selected in HailDropDown, do nothing and exit this sub.
If HailDropDown = "" Then
Exit Sub
'If a hail option is selected, execute the following code.
Else
.TextRange.Text = .TextRange.Text & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & dict2.Item(Ky)(0)
End If
End With
Next
Set dict2 = Nothing
End Sub
You were only referencing .TextRange, rather than .TextRange.Text.
Also, because you need to add the text at the end, you only need an Else condition, rather than two ElseIfs that both do the same thing! ;0)
More example code ... https://msdn.microsoft.com/en-us/library/office/ff822136.aspx