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
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 am trying to make a copy of a workbook that I have, based on list of IDs. I have got this to work OK if I hard code the path, however I can't figure out how to do this where specifying the path using msoFileDialogFolderPicker.
I have tried a number of variations depending on what I have found online and have got as far as below but stuck. Help appreciated.
Dim xFilepath As Variant
Dim xFilename As String
xFilepath = Application.FileDialog(msoFileDialogFolderPicker)
xFilename = Range("Table9[ProgramID]") & " Product Financial Allocation" & ".xlsb"
With xFilepath
.Title = "Choose Destination"
.SHOW
mypath = .SelectedItems(1) & "\"
End With
mypath = mypath
Sheets("FILES").Range("A3").Select
For i = 1 To 3
Sheets("FILES").Range("A" & i).copy Sheets("TEMPLATE").Range("Table9[ProgramID]")
ActiveWorkbook.SaveCopyAs Filename:=mypath & Filename
FileFormat = 50
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
Workbooks.Open Filename:=mypath & Filename
Call DeleteQueries
ActiveWorkbook.Save
ActiveWorkbook.Close
Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
You can use the following code can be used to select folder and then you can append the folder path with file name.
Sub ChooseFolder()
Dim sFolder As String
' Open the select folder prompt
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
If .Show = -1 Then ' if OK is pressed
sFolder = .SelectedItems(1)
End If
End With
Filename = "Test.xlsx"
Filepath = sFolder + "\" + Filename
If sFolder <> "" Then ' if a file was chosen
MsgBox Filepath 'Use this for further processing
End If
End Sub
Following code can be used select single file.
Private Sub ChooseFile()
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Please select the file."
.Filters.Clear
.Filters.Add "Excel File", "*.xlsx"
If .Show = True Then
txtFileName = .SelectedItems(1) 'replace txtFileName with your textbox
End If
End With
MsgBox txtFileName
End Sub
I have this VBA code to convert CSV to XLSX, which seems to work but output Excel have strange strings like "Aço" and "plástico" instead of "Aço" or "plástico". I think solution is to include "Unicode UTF-8", but I couldn't find a way. Any help would be appreciated.
Sub CSVtoXLSX()
Dim xFd As FileDialog
Dim xSPath As String
Dim xCSVFile As String
Dim xWsheet As String
Application.DisplayAlerts = False
Application.StatusBar = True
xWsheet = ActiveWorkbook.Name
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
xFd.Title = "Select a folder:"
If xFd.Show = -1 Then
xSPath = xFd.SelectedItems(1)
Else
Exit Sub
End If
If Right(xSPath, 1) <> "\" Then xSPath = xSPath + "\"
xCSVFile = Dir(xSPath & "*.csv")
Do While xCSVFile <> ""
Application.StatusBar = "Converting: " & xCSVFile
Workbooks.Open Filename:=xSPath & xCSVFile
ActiveWorkbook.SaveAs Replace(xSPath & xCSVFile, ".csv", ".xlsx", vbTextCompare), xlWorkbookDefault
ActiveWorkbook.Close
Windows(xWsheet).Activate
xCSVFile = Dir
Loop
Application.StatusBar = False
Application.DisplayAlerts = True
End Sub
Writing a code to save a file with a defined filename to a specific folder entered by the user. However the file is being saved in a location previous to the specified location. For example I provide file save path as "C:\Users\arorapr\Documents\PAT" but the file is saving it in the path "C:\Users\arorapr\Documents". I have written the below code.
File_Name = Format(Now(), "DDMMYYYY") & "_" & LName & EmpIN & "_" & Range("C6").Value & "_" & Range("J3").Value & "_" & "PAT"
Application.DisplayAlerts = False
MsgBox "Please select the folder to save PAT"
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
End With
ActiveWorkbook.saveas Filename:=File_Name & ".xlsm", FileFormat:=52
Application.DisplayAlerts = True
ActiveWorkbook.Close
Your challenge is that you're opening a file dialog, but not using the user's choice from that in the saveas. Try something along these lines:
Sub SaveFile()
Dim FolderName As String
File_Name = Format(Now(), "DDMMYYYY") & "_" & LName & EmpIN & "_" & Range("C6").Value & "_" & Range("J3").Value & "_" & "PAT"
Application.DisplayAlerts = False
MsgBox "Please select the folder to save PAT"
' Pop up the folder-selection box to get the folder form the user:
FolderName = GetFolder()
' If the user didn't select anything, you can't save, so tell them so:
If FolderName = "" Then
MsgBox "No folder was selected. Program will terminate."
Exit Sub
End If
' Create a path by combining the file and folder names:
File_Name = FolderName & "\" & File_Name & ".xlsm"
ActiveWorkbook.SaveAs Filename:=File_Name, FileFormat:=52
Application.DisplayAlerts = True
ActiveWorkbook.Close
End Sub
' A separate function to get the folder name and return it as a string
Function GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Hope that helps.
In your code, you are not saving the path of the selected folder to a variable. In the code below, the path is saved to the variable selectedFolder, which gets its value from fldr.SelectedItems(1). Then the path + "\" + YourFileName & .xlsm is saved:
Option Explicit
Sub TestMe()
Dim fldr As FileDialog
Dim selectedFolder As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.Show
selectedFolder = .SelectedItems(1)
End With
ActiveWorkbook.SaveAs Filename:=selectedFolder & "\" & "YourFileName" & ".xlsm"
End Sub
Or alternatively, you may use a function, returning the folder's path from here:
VBA - Folder Picker - set where to start
A robust funciton, that I am using to GetFolder is this one:
Option Explicit
Sub myPathForFolder()
Debug.Print GetFolder(Environ("USERPROFILE"))
End Sub
Function GetFolder(Optional InitialLocation As String) As String
On Error GoTo GetFolder_Error
Dim FolderDialog As FileDialog
Dim SelectedFolder As String
If Len(InitialLocation) = 0 Then InitialLocation = ThisWorkbook.Path
Set FolderDialog = Excel.Application.FileDialog(msoFileDialogFolderPicker)
With FolderDialog
.Title = "My Title For Dialog"
.AllowMultiSelect = False
.InitialFileName = InitialLocation
If .Show <> -1 Then GoTo GetFolder_Error
SelectedFolder = .SelectedItems(1)
End With
GetFolder = SelectedFolder
On Error GoTo 0
Exit Function
GetFolder_Error:
Debug.Print "Error " & Err.Number & " (" & Err.Description & ")
End Function
how can I change the format from xlsm to xlsx. I need a script that will save a copy of the xlsm file with xlsx extension, but doesn't ask user to input file name, it needs to keep the original name, the only thing the user needs to do is select where to save the file.
Sub changeext()
Dim s_as As String
s_as = ThisWorkbook.FullName
s_as = Left(s_as, InStrRev(s_as, ".") - 1) & ".xlsx"
ThisWorkbook.SaveAs FileName:=s_as
Application.DisplayAlerts = False
End Sub
I think you only want to add a .xlxs copy not write over your macro enabled workbook. Try the below line of code, it should work, put your workbook name in "put Workbook name here", the file left open will be the .xlsx file.
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.Path & "\" & "Put Workbook Name here" & ".xlsx", FileFormat:=51, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
You need to create FolderPicker Function:
Sub changeext()
Dim objFolder As Object, objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(ChooseFolder)
ThisWorkbook.SaveCopyAs Filename:=objFolder & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & "xlsx"
End Sub
Function ChooseFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder to save down the copy of this workbook"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
ChooseFolder = sItem
Set fldr = Nothing
End Function