A word doc is in the same folder of number.vbs, and we want to open the vbs using macro of the word, we use the address of current folder and number.vbs instead of absolute address (because we might move the folder)
if using absolute address, the following code works
Sub AutoOpen()
CreateObject("Wscript.Shell").Run """C:\Users\yushuo\Desktop\doc sss test\number.vbs """, 1, True
End Sub
then I use the following to get and set address automatically and store in myWb, but doesn't work in CreateObject.run
Sub AutoOpen()
Dim wb As String
Dim myPath As String
Dim myWb As String
wb = "number.vbs"
myPath = ActiveDocument.Path
myWb = myPath & "\" & wb
'MsgBox myWb, 48
CreateObject("Wscript.Shell").Run """myWb """, 1, True
End Sub
I also tried
CreateObject("Wscript.Shell").Run """myPath & " \ " & wb""", 1, True
still not working, also tried
CreateObject("Wscript.Shell").Run myWb, 1, True
still not workng, any idea?
We just need to set myWb as address instead of string, using
myWb = """" & myPath & "\" & wb & """"
so the complete code is
Sub AutoOpen()
Dim wb As String
Dim myPath As String
Dim myWb As String
wb = "number.vbs"
myPath = ActiveDocument.path
myWb = """" & myPath & "\" & wb & """"
' MsgBox myWb, 48
CreateObject("Wscript.Shell").Run myWb, 1, True
End Sub
Related
I have 250 excel documents where I try to print a sheet for pdf. If I do it manually, it will be 4 pages, but if I use my code, it will be 7 pages long.
It's like it ignores the print area, and makes several blank pages.
Can any of you figure out the mistake?
Dim wb As Workbook
Dim xExtension As String: xExtension = "*.xls*"
Dim xFolder As String: xFolder = [MailFolder]
Dim xFile As String: xFile = Dir(xFolder & xExtension) 'DIR gets the first file of the folder
Dim Rng As Range: Set Rng = Range("A1")
Dim s As String
Do While xFile <> "" 'Loop through all files in a folder until DIR cannot find anymore
Set wb = Workbooks.Open(xFolder & xFile): wb.Activate
Call WorksheetsToPDF(wb, "F:\VBA\PDF\Udlejning\" & CleanFileName("Police - " & "2021 -" & [KompletPoliceNr] & " - " & [Forsikringstager]) & ".pdf", "Certifikat")
'Call WorksheetsToPDF(wb, "F:\VBA\KF Begæringer\" & CleanFileName("KF Begæring-2021-" & [KompletPoliceNr] & "-" & [Forsikringstager]) & ".pdf", "Police")
wb.Close savechanges:=False
xFile = Dir()
Loop
End Sub
Private Sub WorksheetsToPDF(wb As Workbook, DistinationPath As String, ParamArray Arr() As Variant)
wb.Sheets(Arr()).Select
Debug.Print EFDK.GetNextavailablefilename(DistinationPath)
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=EFDK.GetNextavailablefilename(DistinationPath), Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False
End Sub
Private Function GetNextAvailableFilename(ByVal xPath As String) As String
With CreateObject("Scripting.FileSystemObject")
Dim strFolder As String, strBaseName As String, strExt As String, i As Long
strFolder = .GetParentFolderName(xPath)
strBaseName = .GetBaseName(xPath)
strExt = .GetExtensionName(xPath)
Do While .FileExists(xPath)
i = i + 1
xPath = .BuildPath(strFolder, strBaseName & " - " & i & "." & strExt)
Loop
End With
GetNextAvailableFilename = xPath
End Function
You did not answer my clarification questions...
Just for the sake of testing, please try the next adapted function:
Private Sub WorksheetsToPDF(wb As Workbook, DistinationPath As String, ParamArray arr() As Variant)
Dim El
wb.Sheets(arr()).Select
For Each El In arr()
wb.Sheets(El).PageSetup.FitToPagesWide = 1
wb.Sheets(El).PageSetup.PaperSize = xlPaperA4 ' xlPaperLetter
wb.Sheets(El).PageSetup.Orientation = xlLandscape
Next
'Debug.Print EFDK.GetNextavailablefilename(DistinationPath)
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=EFDK.GetNextavailablefilename(DistinationPath), Quality:=xlQualityStandard, IncludeDocProperties:=True
End Sub
With no coding knowledge, I have attempted to use some code found here: Automatically name a file based on cell data when saving a spreadsheet?. Thanks to Jean-François Corbett
I have adapted as follows to show the dialog box:
Sub SaveAsString()
Dim strPath As String
Dim strFolderPath As String
strFolderPath = "N:\PROJECTS\"
strPath = strFolderPath & _
Sheet1.Range("B2").Value & "_" & _
Sheet1.Range("B6").Value & "_" & _
Sheet1.Range("X1").Value & "-JS-1" & ".xlsm"
Application.Dialogs(xlDialogSaveAs).Show strPath
ActiveWorkbook.SaveAs FileFormat:=xlOpenXMLWorkbookMacroEnabled
End Sub
I am opening an .xltm file, and attempting to save with the ability to select the subfolder of N:\PROJECTS\ with the combination of cell references shown.
The dialog box appears fine, already showing N:\PROJECTS. However, it does not fill the file name, unless the file is first saved as a .xlsm. It then always attempts to overwrite as well.
This worked for me, utilizing a slightly different code technique.
Option Explicit
Sub SaveAsString()
Dim strPath As String
Dim strFolderPath As String
ChDir "N:\PROJECTS\" 'set directory with this line
With Sheet1
strPath = .Range("B2").Value
strPath = strPath & "_" & .Range("B6").Value
strPath = strPath & "_" & .Range("X1").Value
strPath = strPath & "-JS-1.xlsm"
End With
Application.Dialogs(xlDialogSaveAs).Show strPath 'load file name with this argument
ActiveWorkbook.SaveAs FileFormat:=xlOpenXMLWorkbookMacroEnabled
End Sub
The main issue remaining was that opening from a template didn't automatically save as .xlsm. Apparently Application.Dialogs doesn't support file filters, so the problem is better solved with GetSaveasFileName.
Full code as follows:
Sub SaveAsString()
Dim strPath As String
Dim strFolderPath As String
strFolderPath = "N:\PROJECTS\"
strPath = strFolderPath & _
Sheet1.Range("B2").Value & "_" & _
Sheet1.Range("B6").Value & "_" & _
Sheet1.Range("X1").Value & "-JS-1" & ".xlsm"
fileSaveName = Application.GetSaveAsFilename(strPath _
, fileFilter:="Excel Files (*.xlsm), *.xlsm")
End Sub
I have a folder which has a bunch of .xls files, of which only those which have the KEY Word " CITIES " are of interest to me. I need to open those files and collect some information and I am facing some issues.
Sub getTheExecSummary()
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
myPath = "C:\Users\Morpheus\Documents\Projects\Files"
myExtension = "*.xls" 'How to add the keyword?'
myFile = Dir(myPath & myExtension)
Do While Len(myFile) > 0
'Set variable equal to opened workbook
Set wb = Workbooks.Open(Filename:=myPath & myFile)
Debug.Print (myFile)
Debug.Print (wb.Name)
ActiveSheet.Range("A1").Value = wb.Name
'Get next file name
myFile = Dir
Loop
End Sub
I did write a few Debug.Print statements none of which seem to work. I want to for now print only those workbooks which have the keyword ' CITIES ' in their name.
I think that you want the Instr function.
If Instr(wb.Name, "CITIES") > 0 then .....
You might want to use "CITIES " or " CITIES " to exclude any unintentional uses of those letters, depending on how the filename is setup
Use the wildcard to identify the missing letters: *CITIES*.xls or *CITIES*.xls* if you're expecting xlsx, xlsm, etc.
Sub Test()
Dim colFiles As Collection
Dim vItem As Variant
Dim wrkBk As Workbook
Dim sPath As String
Set colFiles = New Collection
sPath = "C:\Users\Morpheus\Documents\Projects\Files\"
'you could use:
'sPath = Environ("UserProfile") & "\Documents\Projects\Files\"
EnumerateFiles sPath, "*CITIES*.xls", colFiles
For Each vItem In colFiles
Set wrkBk = Workbooks.Open(vItem)
wrkBk.Worksheets("Sheet1").Range("A1") = wrkBk.Name
Next vItem
End Sub
Sub EnumerateFiles(ByVal sDirectory As String, _
ByVal sFileSpec As String, _
ByRef cCollection As Collection)
Dim sTemp As String
sTemp = Dir$(sDirectory & sFileSpec)
Do While Len(sTemp) > 0
cCollection.Add sDirectory & sTemp
sTemp = Dir$
Loop
End Sub
I'm trying to create folders in a test folder through vba, but it doesn't work. I can't figure out why - the commands seem legal.
Option Explicit
Sub createFolders()
Dim homePath As String
Dim folderName As String
Dim foldersNumber As Long
homePath = ThisWorkbook.Worksheets("setup").Cells(1, 2).Value & "\"
folderName = ThisWorkbook.Worksheets("setup").Cells(2, 2).Value
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim i As Long
For i = 1 To foldersNumber
If Not fso.FolderExists(homePath & folderName & i) Then
fso.CreateFolder (homePath & folderName & i)
Else
MsgBox ("Folder exits")
End If
Next
MsgBox ("DONE")
End Sub
I am having problems with my code since it only works in the specific folders but not in all subfolders inside the particular folder.
Could someone please helps to make the code works to all subfolders inside that specific folder? :)
These are my code:
Sub Execute1()
Dim monthstr As String
Dim year As String
Dim monthtext As String
Dim prevmonth As String
Dim prevmonthtext As String
year = Range("D8").Text
monthstr = Trim(Range("D9").Text)
monthtext = Trim(Range("D10").Text)
prevmonth = Trim(Range("D11").Text)
prevmonthtext = Trim(Range("D12").Text)
prevyear = Trim(Range("D13").Text)
'confirmation box before running macro//////////////////////////////////////////////////////////////////////////////////////
response = MsgBox("Are you sure the settings are correct?", vbYesNo, "Confirmation")
If response = vbNo Then
Exit Sub
End If
'optimize macro speed///////////////////////////////////////////////////////////////////////////////////////////////////////////
Call Optimize
'finding the correct path (month)//////////////////////////////////////////////////////////////////////////////////////////
Dim myfile As String
Dim mypath As String
Dim newpath As String
mypath = "C:\Users\praseirw\Desktop\Tes CC\" & prevyear & "\SC\" & prevmonth & " " & prevmonthtext & "\"
myfile = Dir(mypath & "*.xlsx")
newpath = "C:\Users\praseirw\Desktop\Tes CC\" & year & "\SC\" & monthstr & " " & monthtext & "\"
'loop through all files in specified month//////////////////////////////////////////////////////////////////////////////////
Dim root As Workbook
Dim rng As Range
Dim wb As Workbook
Dim ws As Worksheet
Set root = Workbooks("CC Reports Center.xlsm")
Set rng = root.Worksheets("Settings").Range("H7:H14")
Do While myfile <> ""
Set wb = Workbooks.Open(mypath & myfile)
For Each ws In wb.Worksheets
rng.Copy
With ws.Range("D1")
.PasteSpecial xlPasteFormulas
End With
Next ws
Dim oldname As String
Dim newname As String
Dim wbname As String
oldname = wb.Name
wbname = Mid(oldname, 9)
newname = year & "_" & monthstr & "_" & wbname
wb.SaveAs Filename:=newpath & newname
wb.Close
Set wb = Nothing
myfile = Dir
Loop
Application.CutCopyMode = False
MsgBox "Task Complete!"
'reset macro optimization settings//////////////////////////////////////////////////////////////////////////////////////////////
Call ResetOptimize
End Sub
Here's one way to do it with the Dir function. If you want something a little more elegant you may want to consider using a FileSystemObject. (Note that to view Debug.Print output you have to enable the immediate window from under view.)
Sub test()
Dim root As String
root = "C:\"
Dim DC As New Collection
s = Dir(root & "*", vbDirectory)
Do Until s = ""
DC.Add s
s = Dir
Loop
For Each D In DC
Debug.Print D
On Error Resume Next: s = Dir(root & D & "\*.xl*"): On Error GoTo 0
Do Until s = ""
Debug.Print " " & s
s = Dir
Loop
Next
End Sub
Here's an example of how to do this with a FileSystemObject. Note that my code is a little sloppy with "On error resume next" to protect against access denied or other errors. Realistically you may want to consider incorporating better error handling, but that's another topic. Using a FileSystemObject is more powerful than Dir because Dir only returns a string, while FileSystemObject lets you work with files and folders as actual objects, which are much more powerful.
Sub test()
'You can use "CreateObject..." to add a FileSystemObject from the Scipting Library
'Alternatively, you can add a reference to "Microsoft Scripting Runtime"
'allowing you to directly declare a filesystemobject and access related intellisense
Set fso = CreateObject("Scripting.FileSystemObject")
Set Folder = fso.GetFolder("C:\")
For Each SubFolder In Folder.SubFolders
Debug.Print SubFolder.Name
On Error Resume Next
For Each File In SubFolder.Files
Debug.Print " " & File.Name
Next
On Error GoTo 0
Next
End Sub