I've recently started experimenting with vba to automate some of my daily tasks in Microsoft Word. I am working on a code that will allow the user to select a destination folder and also the files (.doc) to be copied into the selected destination folder.
The following code runs with no errors, however the files do not get copy pasted into the destination folder.
I will greatly appreciate any help to resolve this minute issue.
Regards,
Derek
Sub copydocs()
Dim items As Long
Dim file_path As Variant
Dim folder_path As Variant
'Ask user for input'
items = InputBox("Give me some input")
'Select Destination Folder
With Application.FileDialog(msoFileDialogFolderPicker)
folder_path = .SelectedItems(1)
.Show
End With
' Open the file dialog
For i = 1 To items
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.Show
file_path = .SelectedItems(1)
End With
' Copy paste
Dim fs As Object
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile file_path, folder_path
Set fs = Nothing
Next i
End Sub
There are a couple of issues.
The variable i isn't declared anywhere.
You are attempting to save the folder path before the dialogue has returned it.
Sub copydocs()
Dim i As Integer ' CHANGE: New declare.
Dim fs As Object ' CHANGE: Moved to top.
Dim items As Long
Dim file_path As Variant
Dim folder_path As Variant
'Ask user for input.
items = InputBox("Give me some input")
'Select Destination Folder
With Application.FileDialog(msoFileDialogFolderPicker)
' CHANGE: Switched order of next two lines.
.Show
folder_path = .SelectedItems(1)
End With
' Open the file dialog
For i = 1 To items
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = True
.Show
file_path = .SelectedItems(1)
End With
' Copy paste
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile file_path, folder_path
Set fs = Nothing
Next i
End Sub
Related
Recently, my organization changed the name of our One Drive causing hyperlinks in my documents linking to other files in the One Drive to become obsolete.
I am trying to create a VBA script that will ask the user for a directory, go through each word doc in the folder and subfolder (and subfolder's subfolder, etc...) and replace a section of all the hyperlinks. I am new to VBA so please, don't hesitate to point out anything.
So far, this is what I have but I can't get it to change what's in the file, let alone go through all the subfolders:
Sub getDirectory()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Dim FileSystem As Object
Dim HostFolder As String
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
'Get the directory from user
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.doc*")
End If
'convert directory into string
With xFd
.Filters.Clear
.AllowMultiSelect = False
.Show
Path = .SelectedItems(1)
End With
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(Path)
End Sub
Sub DoFolder(Folder)
'loop through folders after calling LoopThroughFiles
Dim SubFolder
Dim File
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
For Each File In Folder.Files
' Operate on each file
Call LoopThroughFiles
Next
End Sub
Sub LoopThroughFiles()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Dim h As Hyperlink
Dim sOld As String
Dim sNew As String
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
Do While xFileName <> ""
With Documents.Open(xFdItem & xFileName)
Application.ScreenUpdating = False
'Replace this:
sOld = "AAAA"
'With this:
sNew = "BBBB"
'Example: C:\Users\Me\AAAA\file.doc ---> C:\Users\Me\BBBB\file.doc
'replace hyperlinks
For Each h In ActiveDocument.Hyperlinks
h.Address = Replace(h.Address, sOld, sNew)
Next h
Application.ScreenUpdating = True
End With
xFileName = Dir
Loop
End Sub
I have a folder with many different files and I want to insert a column with the name of the file.
This is my code:
Sub AllWorkbooks()
Dim MyFolder As String 'Path collected from the folder picker dialog
Dim MyFile As String 'Filename obtained by DIR function
Dim wbk As Workbook 'Used to loop through each workbook
On Error Resume Next
Application.ScreenUpdating = False
'Opens the folder picker dialog to allow user selection
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then 'If no folder is selected, abort
MsgBox "You did not select a folder"
Exit Sub
End If
MyFolder = .SelectedItems(1) & "\" 'Assign selected folder to MyFolder
End With
MyFile = Dir(MyFolder) 'DIR gets the first file of the folder
'Loop through all files in a folder until DIR cannot find anymore
Do While MyFile <> ""
'Opens the file and assigns to the wbk variable for future use
Set wbk = Workbooks.Open(Filename:=MyFolder & MyFile)
'Replace the line below with the statements you would want your macro to perform
Sheets(1).Range("j1").Value = "Date"
wbk.Close savechanges:=True
MyFile = Dir 'DIR gets the next file in the folder
Loop
Application.ScreenUpdating = True
End Sub
So what I want to do is add some part of the file name to the entire J column except the header that is "Date" which I already implemented in the code above.
Thanks in advance
Add this code just after your "Date" value setting and before you close and save changes:
Dim i As Long
For i = 2 To Sheets(1).UsedRange.Rows.Count
Sheets(1).Range("J" & i).Value = MyFile
Next i
This will insert the whole filename to the J column for each row, except for the header (2), that has data in the sheet. You should now be able to adapt this code for "some part of the filename" (you don't say which part!).
I insert a number of pictures from a Folder. The program is supposed to start at the top of the folder and insert the pictures in a descending order, but it does not.
The very first 3-5 pictures come last in the presentation, while all others are in perfect order.
Sub createTransModel()
Dim oSlide As Slide
Dim oPicture As Shape
Dim myFile As String
Dim myFolder As String
Dim pptLayout As CustomLayout
Dim fileName As String
Dim rotSlide As Slide
Set pptLayout = ActivePresentation.Slides(1).CustomLayout
myFolder = GetFolderPath()
myFile = Dir(myFolder & "*.png")
Do While myFile <> ""
Set oSlide = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, _
ppLayoutBlank)
Set oPicture = oSlide.Shapes.AddPicture(myFile, _
msoFalse, msoTrue, 1, 1, _
ActivePresentation.PageSetup.SlideWidth, _
ActivePresentation.PageSetup.SlideHeight)
myFile = Dir
Loop
fileName = inputBox("Please enter the filename")
ActivePresentation.SaveAs (fileName & ".pps")
End Sub
Public Function GetFolderPath() As String
Dim myFile As Object
Dim fileSelected As String
Dim path As String
Dim objPPT As Object
Dim i As Integer
Dim folderFromPath As String
Dim directory As String
directory = "M:\tm\public\Conti_Anlage\Voith Proben"
Set myFile = Application.FileDialog(msoFileDialogOpen)
With myFile
.InitialFileName = directory
.Title = "Choose File"
.AllowMultiSelect = False
If .Show <> -1 Then
Exit Function
End If
fileSelected = .SelectedItems(1)
End With
For i = Len(fileSelected) To 1 Step -1
If Mid(fileSelected, i, 1) = "\" Then
folderFromPath = Left(fileSelected, i)
Exit For
End If
Next
GetFolderPath = folderFromPath
End Function
There are a couple of things here
1. To resolve your order issue, you could get all the files in the folder (i.e. use a 'For' loop: For Each oFile in oMyFolder.Files) and then order them the way you want them (maybe in an array). Now you can add them.
2. Your 'GetFolderPath' function: from what I can see, you want the user to select a file and then you are returning the folder of the selected file. You could just use 'Application.FileDialog(msoFileDialogFolderPicker)'. This will ask the user to select a folder. This way you don't have to worry about extracting the folder. If you still want to get the folder of the selected file, have a look at 'File System' object. You could use that to get the folder (i.e. filesystemobject.GetParentFolderName(MyFile))
The order of files that you see in a Windows file explorer window depends on your file explorer settings. Files might be displayed alphabetically by name, in size order or sorted in various other ways. That's file explorer's doing and has nothing to do with the actual order in which the files appear on the disk.
Dir$ when called repeatedly gives you the files in the order in which they appear on the disk. If you want them in a particular order, you'll have to sort them or perhaps copy them into a folder in the order you want them to be returned by Dir.
I'm having an issue that when I try to use multiple instances of file dialogs the information from the first is always overwritten by the selection in the second dialog.
What i need to do is:
Select a template file
Select a destination folder
Save the template file as a .docm file.
What happens is that the second time application.FileDialog is used all the information in fd is lost and is overwritten by the entries into fldr.
Can there only be one dialog object per macro?
Dim fd As FileDialog
Dim FileChosen As Integer
Dim FileName As String
Dim fldr As FileDialog
Dim fldrSelect As String
Dim i As Integer
Set fd = Application.FileDialog(msoFileDialogFilePicker)
'use the standard title and filters, but change the
'initial folder
fd.InitialFileName = "H:\UpdatedSalesTemplates\"
fd.InitialView = msoFileDialogViewList
'allow multiple file selection
fd.AllowMultiSelect = True
FileChosen = fd.Show
If FileChosen = -1 Then
'Select the directory using a file dialog
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
fldr.InitialView = msoFileDialogViewList
fldr.Title = "Select Destination"
fldr.AllowMultiSelect = False
fldrSelected = fldr.Show
'
Microsoft says that there may be only one: "...Each host application can only create a single instance of the FileDialog object...".
In any case, this shouldn't represent a serious problem as far as you can store all the relevant information (selected path, initial directory, etc.) in (string) variables.
For such scenarios where you need a file/folder picker in one macro/procedure/userform, I use a custom made userform. See if you like it. Place commandbuttons and textboxes as shown below
Screenshot
Code
Note: Both the textboxes .Locked property was set to True in design time so that the user cannot modify the textboxes manually.
Option Explicit
Dim Ret
'~~> Browse File
Private Sub CommandButton1_Click()
Ret = Application.GetOpenFilename("Excel Files (*.xlsx), *.xlsx")
If Ret <> False Then TextBox1.Text = Ret
End Sub
'~~> Browse Folder
Private Sub CommandButton2_Click()
Ret = BrowseForFolder("C:\")
If Ret <> False Then TextBox2.Text = Ret
End Sub
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
'~~> If it was determined that the selection was invalid, set to False
BrowseForFolder = False
End Function
I have below Excel procedure I gather up and I am using it for couple of different calculations under different workbooks. So I was thinking instead changing the procedure for main and outcome files each time, I should be able to pick the file I want to carry out calculations in and the file path for outcomes files.
But I could not find anything for saving directory, I appreciate if you could help
Sub AsBuiltForm()
Dim SaveName As String
Dim mainBook As Workbook
a = InputBox("ENTER FIRST NUMBER ")
b = InputBox("ENTER LAST NUMBER ")
Workbooks.Open Filename:="C:\" 'main file can be browsed?
Set mainBook = Excel.Workbooks("CP.xlsx")
For i = a - 1 To b - 1
mainBook.Sheets(1).Range("bi1") = i + 1
SaveName = Sheets(1).Range("bi1").value & ".xlsx"
mainBook.SaveCopyAs "C:\" & SaveName 'save directory?
Workbooks.Open Filename:="C:\" & SaveName 'save directory?
With Excel.ActiveWorkbook
.Sheets("1 of 2").Range("A1:CT103").value = Sheets("1 of 2").Range("A1:CT103").value
.Sheets("2 of 2").Range("A1:CT103").value = Sheets("2 of 2").Range("A1:CT103").value
Excel.Application.DisplayAlerts = False
.Sheets("Sheet1").Delete
.Sheets("il oufall").Delete
.Sheets("1 of 2").Select
Columns("Bh:BZ").Select
Selection.Delete Shift:=xlToLeft
.Sheets("2 of 2").Select
Columns("Bn:BZ").Select
Selection.Delete Shift:=xlToLeft
.Close True
End With
Next
mainBook.Close False
Set mainBook = Nothing
End Sub
You can use Application.GetOpenFileName to pick files that you want to open at Run-Time.
You can use the function below to browse for a folder where you wish to save a file.
Sub FindFolder()
Dim myFolder as String
myFolder = BrowseFolder("Pick a Folder Where to Save")
End Sub
Function BrowseFolder(Optional Caption As String, Optional InitialFolder As String) As String
' based on Browse For Folder from:
' http://www.cpearson.com/excel/BrowseFolder.aspx
' this functions requires that the following Reference is active:
'Microsoft Shell Controls and Automation
Const BIF_RETURNONLYFSDIRS As Long = &H1
Dim wsh As Object
Dim SH As Shell32.Shell
Dim F As Shell32.Folder
Set wsh = CreateObject("Wscript.Shell")
Set SH = New Shell32.Shell
Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder)
If Not F Is Nothing Then
If F = "Desktop" Then
BrowseFolder = wsh.Specialfolders(F)
Else
BrowseFolder = F.Items.Item.path
End If
End If
End Function
The following is not really an answer to your question, but a few tips to improve your code, and too long to add as a comment.
Workbooks.Open returns a Workbook object you can save the reference, so you don't have to rely on ActiveWorkbook:
Dim oWorkbook As Workbook
Set oWorkbook = Workbooks.Open(Filename:="C:\" & SaveName)
'***** Do something with oWorkbook
Debug.Print oWorkbook.FullName
Set oWorkbook = Nothing
A few other hints:
Use Option Explicit at the top of every module to force explicit declaration of all variables in order to find typos and other errors earlier.
Avoid selecting cells
Yes, browsing file works now; all the ins and outs aside, the problem i face with naming the file due to the variable "bi1" and saving as many loop as i asked for. I check several times before i bother you but i do not think i have the sufficient info to address "fn" as file in the use of Application.GetOpenFileName .
Option Explicit
Sub AsBuiltForm()
Dim fn
Dim myFolder As String
Dim SaveName As String, a As Integer, b As Integer, i As Integer
myFolder = BrowseFolder("Pick a Folder Where to Save")
MsgBox "Choose Calculation File "
fn = Application.GetOpenFilename
Workbooks.Open fn
a = InputBox("ENTER FIRST NUMBER ")
b = InputBox("ENTER LAST NUMBER ")
For i = a - 1 To b - 1 Step 1
Application.DisplayAlerts = False
Workbooks.Open Filename:=fn
Range("bi1") = i + 1
SaveName = ActiveWorkbook.Sheets(1).Range("bi1").value
Sheets(1).Range("A1:CT103").value = Sheets(1).Range("A1:CT103").value
Sheets(2).Range("A1:CT103").value = Sheets(2).Range("A1:CT103").value
Application.ActiveWorkbook.SaveAs myFolder & SaveName
ActiveWorkbook.Close True
Next
End Sub
Function BrowseFolder(Optional Caption As String, Optional InitialFolder As String) As String
' based on Browse For Folder from:
' http://www.cpearson.com/excel/BrowseFolder.aspx
' this functions requires that the following Reference is active:
'Microsoft Shell Controls and Automation
Const BIF_RETURNONLYFSDIRS As Long = &H1
Dim wsh As Object
Dim SH As Shell32.Shell
Dim F As Shell32.Folder
Set wsh = CreateObject("Wscript.Shell")
Set SH = New Shell32.Shell
Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder)
If Not F Is Nothing Then
If F = "Desktop" Then
BrowseFolder = wsh.Specialfolders(F)
Else
BrowseFolder = F.Items.Item.Path
End If
End If
End Function