I have the following code and the YesNoCancel options don't do anything. What am I doing wrong please?
Option Explicit
Sub wwb()
'lists each book that's OPEN
Dim wb As Workbook, ws As Workbook, wd As Workbook
Set wd = ThisWorkbook
MsgBox wd.Name
Dim output As Integer
Dim msgValue
For Each wb In Application.Workbooks
If wb.Name = wd.Name Then
MsgBox "The destination WorkBook is :" & wd.Name
Else
output = MsgBox("Is " & wb.Name & " your source file to import data?", vbYesNoCancel, "Please confirm source file")
If msgValue = vbYes Then
MsgBox "test yes"
ElseIf msgValue = vbNo Then
MsgBox "test No"
ElseIf msgValue = vbCancel Then
MsgBox "Test cancel"
End If
End If
Next wb
End Sub
You need to check output instead of msgValue
output = MsgBox("Is " & wb.Name & " your source file to import data?", vbYesNoCancel, "Please confirm source file")
If output = vbYes Then
MsgBox "test yes"
ElseIf output = vbNo Then
MsgBox "test No"
ElseIf output = vbCancel Then
MsgBox "Test cancel"
End If
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 have a VBA macro code to SAVE AS an Excel Invoice using a button. Whenever I click "YES", the file is saved again. But when I click "NO", "CANCEL" or even CLOSE the MSgBox window, I Get Run-time error '1004', Cannot access 'filename.xlsm'.
Sub Save_As()
Dim filename As String
Dim msgResponse As VbMsgBoxResult
filename = "C:\Users\bala\Desktop\SDH\Excel Invoice\" & Range("F4") & Range("G4") & "_" & Range("M10")
If Len(Dir(filename)) = 0 Then
ActiveSheet.SaveAs filename, FileFormat:=52, CreateBackup:=True
Application.DisplayAlerts = True
MsgBox "Invoice saved successully", vbOKOnly, "INVOICE SAVED"
Else
msgResponse = MsgBox("Do you want to overwrite?", vbYesNoCancel)
If msgResponse = vbYes Then
ActiveSheet.SaveAs filename, FileFormat:=52, CreateBackup:=True
Application.DisplayAlerts = True
MsgBox "Invoice saved successully", vbOKOnly, "INVOICE SAVED"
Else
Exit Sub
End If
End If
End Sub
You should always check the response to user input, in this case what button was pressed.
Dim msgResponse As VbMsgBoxResult
msgResponse = MsgBox("Do you want to overwrite?", vbYesNoCancel)
If msgResponse = vbYes Then
' Overwrite file
Else
' Don't
End If
My code is suppose to check cell j2 for an email address and if found, convert that specific tab to pdf and save it in a file path that the user chooses. It works fine on the original workbook I made the macro in. When I copy the code and try running it, it prints to pdf different sheets that don't even have anything in j2 with the incorrect tab name. I keep getting an Run time error 5 Invalid procedure call or argument when i run the code on the print pdf line.
Sub SaveSheetsAsPDF()
Dim DestFolder As String
Dim PDFFile As String
Dim wb As Worksheet
Dim AlwaysOverwritePDF As Boolean
'Speed up macro
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Prompt for file destination
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
DestFolder = .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
End With
'Create new PDF file name including path and file extension
For Each wb In ThisWorkbook.Worksheets
'Test j2 for a mail address
If wb.Range("J2").Value Like "?*#?*.?*" Then
PDFFile = DestFolder & Application.PathSeparator & wb.Name & "-" & Format(Date, "mmyy") & ".pdf"
'If the PDF already exists
If Len(Dir(PDFFile)) > 0 Then
If AlwaysOverwritePDF = False Then
OverwritePDF = MsgBox(PDFFile & " already exists." & vbCrLf & vbCrLf & "Do you want to overwrite it?", vbYesNo + vbQuestion, "File Exists")
On Error Resume Next
'If you want to overwrite the file then delete the current one
If OverwritePDF = vbYes Then
Kill PDFFile
Else
MsgBox "OK then, if you don't overwrite the existing PDF, I can't continue." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Exiting Macro"
Exit Sub
End If
Else
On Error Resume Next
Kill PDFFile
End If
If Err.Number <> 0 Then
MsgBox "Unable to delete existing file. Please make sure the file is not open or write protected." _
& vbCrLf & vbCrLf & "Press OK to exit this macro.", vbCritical, "Unable to Delete File"
Exit Sub
End If
End If
End If
'Prints PDF
wb.ExportAsFixedFormat Type:=xlTypePDF, FileName:=PDFFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Next wb
MsgBox "All Files Have Been Converted!"
ResetSettings:
'Resets optimization settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Edit: Also not all worksheets on the workbook will need to converted. So only the sheets that need to be converted will have the email address in J2.
Below code is working fine and doing what I want to do. But when I use it as Add-In to run on all other workbooks it says subscript out of range.
There may be object related confusion or the add-in gets confused which workbook to refer.
I'm new to vba and request all of you to help.
Sub mac_3()
Dim xlsname As String
Dim d As VbMsgBoxResult: d = MsgBox("Would you like to add record?" & vbNewLine & vbNewLine & "(Esc/Cancel to add something.)", vbYesNoCancel + vbQuestion, "Details!")
If d = vbNo Then
Sheets("MPSA").Range("a13").Value = "Record is not available."
Sheets("MPSA").Range("a13").Font.Bold = True
ActiveWorkbook.Save
GoTo savefile
Exit Sub
End If
If d = vbCancel Then
Dim myValue As Variant
myValue = Application.InputBox("Non-Transactional number!", "Please paste number[separate with comma ,]:")
If myValue = False Then
Exit Sub
Else
Sheets("MPSA").Range("a13").Value = "Dataot available for : " & myValue
Sheets("MPSA").Range("a13").Font.Bold = True
ActiveWorkbook.Save
GoTo savefile
Exit Sub
End If
End If
On Error GoTo Cleanup
Application.DisplayAlerts = False: Application.EnableEvents = False: Application.ScreenUpdating = False
Sheets("MPSA").Range("a14:ac14").Value = Array( _
"ACCOUNT NAME", " ACCOUNT NUMBER", "AGE", "ENTITY NAME", "GROUP", _
"ITEM NUMBER", "ITEM NAME", "COMPONENT", "QUANTITY", "SUBSCRIPTIONS", _
"QUANTITY", "QUANTITY", "NUMBER", "ITEM NAME", _
"PART NUMBER", "PART NAME", "EDITION", "TYPE", "VERSION", "USAGE", _
"LIMIT", "NAME", "TART DATE", "END DATE", "ASSET STATUS", _
"CATEGORY", "ACCOUNT TYPE", "METHOD", "CENTER")
Sheets("MPSA").Range("a14:ac14").Font.Name = "Calibri"
Sheets("MPSA").Range("a14:ac14").Interior.ColorIndex = 24
Sheets("MPSA").Range("a14:ac14").Font.Bold = True
Sheets("MPSA").Range("a14:ac14").Borders.LineStyle = xlContinuous
Sheets("MPSA").Columns.AutoFit
Dim Target_Path: Target_Path = Application.GetOpenFilename
Do While Target_Path <> False ' <-- loop until user cancels
Dim Target_Workbook As Workbook: Set Target_Workbook = Workbooks.Open(Target_Path)
Target_Workbook.Sheets(1).Cells.WrapText = True
Target_Workbook.Sheets(1).Cells.WrapText = False
Target_Workbook.Sheets(1).Range("A1").CurrentRegion.Offset(1).Copy _
ThisWorkbook.Sheets("MPSA").Range("a1000000").End(xlUp).Offset(1)
Target_Workbook.Close False
ActiveWorkbook.Save
Dim e As VbMsgBoxResult: e = MsgBox("Another Record?", vbYesNo + vbQuestion, "Next details!")
If e = vbNo Then
ThisWorkbook.Save
GoTo savefile
Exit Sub
End If
'If e = vbYes Then
Target_Path = Application.GetOpenFilename
Loop
GoTo savefile
savefile:
Application.DisplayAlerts = False
xlsname = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 5)ActiveWorkbook.SaveAs Filename:="C:\Users\" & Environ$("username") & "\Desktop\New Folder\" & xlsname & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Cleanup:
If Err.Number <> 0 Then MsgBox "Something went wrong: " & vbCrLf & Err.Description
Application.DisplayAlerts = True: Application.EnableEvents = True: Application.ScreenUpdating = True
End Sub
The problem is solved now. As suggested by #Tom, Add-In was confused about which worksheet to paste values in.
Well I defined another variable using Dim Source_Workbook as Workbook Set Source_Workbook as ActiveWorkbook
Thanks to all of you :)
The Code:
mNummer = InputBox("Please typ a number")
If mNummer = ""
Then MsgBox ("Makro wont function!")
Exit Sub
End If
Year= InputBox("Select Year", Worksheets("Vorgaben").Range("B14").Value)
If Year= ""
Then
MsgBox("Makro wird abgebrochen!")
Exit Sub
End If
Welle = InputBox("Bitte Welle auswählen", , "0" & Worksheets("Vorgaben").Range("B15"))
If Welle = "" Then MsgBox ("Makro wird abgebrochen!")
Exit Sub
End If
'Combine the variables in mNummerGanz '
mNummerGanz = mNummer & "_" & Year& "_" & Welle
Worksheets("Eingabefeld").Range("F2").Value =mNummerGanz
The Question:
So here i combined 3 variables, which are asking for user Inputs with 3 messageboxes. Now the combined Version of it is in variable "mNummerGanz".
Now I would like to open any Excel file by going to any Directory and selecting it. But my macro should check if the Name of the selected Excel file is equals "mNummerGanz.xls". If yes, the file should be opened, if it is not equal to "mNummerGanz.xls" then it should print "error".
Does anyone have Suggestion for this ?
If I've understood correctly, you're building a string which you then want to test to see if it's a valid file name, and if so, open it?
In which case, this snippet should do that for you
If Len(Dir(outputpath & mNummerGanz)) <> 0 Then
Workbooks.Open (outputpath & mNummerGanz)
Else
MsgBox ("That file does not exist")
End If
It checks to see if the file exists (outputpath = folder location)
and if so, opens it.
I can help! Also in German :) Ich kann dir auf Deutsch helfen :)
mNummer = InputBox("Please typ a number")
If mNummer = "" Then
MsgBox ("Makro wont function!")
Exit Sub
End If
Year= InputBox("Select Year", Worksheets("Vorgaben").Range("B14").Value)
If Year= "" Then
MsgBox("Makro wird abgebrochen!")
Exit Sub
End If
Welle = InputBox("Bitte Welle auswählen", , "0" &
Worksheets("Vorgaben").Range("B15").Value
If Welle = "" Then
MsgBox ("Makro wird abgebrochen!")
Exit Sub
End If
'Combine the variables in mNummerGanz '
mNummerGanz = mNummer & "" & Year& "" & Welle
Worksheets("Eingabefeld").Range("F2").Value =mNummerGanz
ANSWER:
'typical excel variables
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Retrieve Target FilePath From User
Set FldrPicker = Application.FileDialog(msoFileDialogFilePicker)
With FldrPicker
.Title = "Select A Target File"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.xls"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
If myFile = "mNummerGanz.xls"
Debug.Print "myFile = " & myFile
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
'Do your stuff here, man.
With wb.Worksheets(1)
'add in your string manipulation / cell dumping here
'with a few lines
End With
'Close opened *.xls, save
wb.Close SaveChanges:=True
Else
GoTo ResetSettings
End If
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True