The script below is incomplete because I would like the destination file to be opened from a folder that the user has previously chosen. The file name is set but the user can choose which folder the file should reside in.
Essentially, the objective of this script is to create a pipe delimited file from an excel sheet residing in this file. Subsequently the user chooses the folder to save down the text file into a folder.
Sub PipeDelimited()
' Exports to PipeDel.txt file
Dim Rng As Range
Dim ws As Worksheet
Dim CurrRow As Range
Dim CurrCell As Range
Dim CurrTextStr As String
Dim ListSep As String
Dim DestFile As String
ListSep = "|"
Set ws = ThisWorkbook.Worksheets("jj")
Set Rng = Worksheets("jj").UsedRange
DestFile ====> use msoFileDialogFolderPicker??????
File name is set under Cell d8 in the tab (sheet) called macros
Open DestFile For Output As #1
For Each CurrRow In Rng.Rows
CurrTextStr = ""
For Each CurrCell In CurrRow.Cells
CurrTextStr = CurrTextStr & CurrCell.Value & ListSep
Next
While Right(CurrTextStr, 1) = ListSep
CurrTextStr = Left(CurrTextStr, Len(CurrTextStr) - 1)
Wend
'Added next line to put | at end of each line
CurrTextStr = CurrTextStr & ListSep
Print #1, CurrTextStr
Next
Close #1
End Sub
I have now added this sub with the intention that the vba script will automatically place a suffix of txt to my file.
The sub below does default my file type to txt. However, when I click on ok, nothing happens. The pop up window "please choose folder location to save this file" pops up each time I click on "ok". However, the file doesn't get saved.
Sub FolderLocation()
Dim folderpath As String
Dim fn As String
Dim fd As FileDialog
fn = ThisWorkbook.Worksheets("MACROS").Range("RngFileName").Value
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.Title = "Please Choose Folder Location to Save this File"
fd.InitialFileName = ThisWorkbook.Worksheets("Macros").Range("RngFileName").Value
fd.AllowMultiSelect = False
fd.Filters.Add "All Files", "*.*"
fd.Filters.Add "Text", "*.txt", 1
fd.FilterIndex = 1
If fd.Show = True Then folderpath = fd.SelectedItems(1)
MsgBox "File Saved", vbOKCancel, folderpath
End Sub
Adapt this basic outline for your code. You will need to concatenate your filename to the selectedFolder path.
Sub getFolder()
Dim newFldrDia As FileDialog
Dim selectedFolder As String
Set newFldrDia = Application.FileDialog(msoFileDialogFolderPicker)
With newFldrDia
.Title = "My Dialog Title"
.AllowMultiSelect = False
If .Show = -1 Then
selectedFolder = .SelectedItems(1)
End If
End With
MsgBox selectedFolder
End Sub
Have a look here for more properties/methods you can use.
Related
I am a VBA noob and I am working on a script that would capture the header and footer settings of all word files in a folder. I would like to create an array, and save the values for header and footer for each file that can be found on the folder. I think I have managed to create the loop, however, I do not know how to save these values to an array.
Here is a sample of my script:
Option Explicit
Public savepath As String
'This will select the file/folder
Public Sub select_folder()
Dim Filepicker As FileDialog
Dim mypath As String
Set Filepicker = Application.FileDialog(msoFileDialogFolderPicker)
With Filepicker
.Title = "Select folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
.ButtonName = "Select(&S)"
If .Show = -1 Then
mypath = .SelectedItems(1) & "\"
Else
End
End If
End With
NextCode:
'select_folder = mypath
Set Filepicker = Nothing
savepath = mypath
End Sub
Sub excel_report()
Dim strFile As String
Dim strInFold As String
Dim extension As String
Dim WrdSrc As Word.document
Dim WrdApp As Word.Application
'count the files in the folder
strInFold = savepath
extension = "*.doc*"
strFile = Dir(strInFold & extension)
Do While strFile <> ""
counter = counter + 1
strFile = Dir
Loop
Dim arry(counter, 3) As Variant
'save values of files into an array
strInFold = savepath
extension = "*.doc*"
strFile = Dir(strInFold & extension)
Do While strFile <> ""
'open word application
On Error Resume Next
' Check whether Word is running
Set WrdApp = GetObject(, "Word.Application")
If WrdApp Is Nothing Then
' Word is not running, create new instance
Set WrdApp = CreateObject("Word.Application")
' For automation to work, Word must be visible
WrdApp.Visible = True
End If
On Error GoTo 0
DoEvents
' open file
Set WrdSrc = WrdApp.Documents.Open(filename:=strInFold & strFile)
'Add Array (arry) Values here
'assign strfile (file name) on column 1
'WrdSrc.Sections(1).Headers(wdHeaderFooterPrimary).Range on column 2
'WrdSrc.Sections(1).Footers(wdHeaderFooterPrimary).Range on column 3
'move to next row
Loop
End Sub
I am trying to achive an output that looks like this:
FileName HeaderValue FooterValue
testfile.doc ABCD Company Confidential Information
Testfile2.doc CDEF Company All rights reserved to CDEF company
And I would like to add this array to a new sheet, then add this sheet to the current workbook where this vba script is running.
How do we go about doing this?
Thank you in advance!
I have 2 problems regarding FileDialog.
The below code is to copy a file from another folder into another. But if it couldn't locate that file, it would open the FileDialog to select the file.
Problems:
When the FileDialog is opened, it would instead default to Documents and not the AltPath.
Is it possible to select 2 or more files with FileDialog without resorting to loop?
Dim fso As Object
Dim ws As Worksheet
Dim targetFile As Object
Dim S_Line As Long
Dim BasePath As String
Dim AltPath As String
Dim AltPath2 As String
Dim MainPath As String
Dim NewPath As String
Dim Position As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set ws = ActiveSheet
BasePath = "Z:\Test\Folder\"
AltPath = "B:\Test\Folder\"
MainPath = BasePath & "File.xlsm"
NewPath = "D:\Folder\"
S_Line = 0
Position = UCase(Trim(ws.Cells(R_Line, 8).Value2))
If Position = "OK" Then
If Right(MainPath, 1) = "\" Then
MainPath = Left(MainPath, Len(MainPath) - 1)
End If
If fso.FileExists(MainPath) = True Then
fso.CopyFile Source:=MainPath, Destination:=NewPath
Else
Do While S_Line < 2
Set targetFile = Application.FileDialog(msoFileDialogFilePicker)
With targetFile
.Title = "Select a File"
.AllowMultiSelect = True
.InitialFolderName = AltPath
If .Show <> -1 Then
MsgBox "You didn't select anything"
Exit Sub
End If
AltPath2 = .SelectedItems(1)
End With
fso.CopyFile Source:=AltPath2, Destination:=NewPath
S_Line = S_Line + 1
Loop
End If
You did not answer my clarification question and your question is not so clear. Please, test the next code. It will open the dialog in the folder you need, and copy the selected items in the folder you want. I commented the lines being strictly connected to your environment (Position, S_Line), since I cannot deduce which are they and how to be used:
Sub copyFileSourceDest()
Dim fso As Object
Dim ws As Worksheet
Dim AltPath2 As String
Dim MainPath As String
Dim NewPath As String
Dim Position As String
Const AltPath As String = "B:\Test\Folder\"
Const BasePath As String = "Z:\Test\Folder\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set ws = ActiveSheet
MainPath = BasePath & "File.xlsm"
NewPath = ThisWorkbook.path & "\NewFold\" ' "D:\Folder\"
'Position = UCase(Trim(ws.cells(R_Line, 8).Value2))
'If Position = "OK" Then
'the following sequence looks useless, since it is a FILE path:
'If Right(MainPath, 1) = "\" Then
' MainPath = left(MainPath, Len(MainPath) - 1)
'End If
If fso.FileExists(MainPath) = True Then
fso.CopyFile Source:=MainPath, Destination:=NewPath
Else
Dim item As Variant
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "Select a File"
.AllowMultiSelect = True
'.InitialFolderName = AltPath 'it does not exist in this Dialog type
.InitialFileName = AltPath
If .Show <> -1 Then
MsgBox "You didn't select anything"
Exit Sub
End If
For Each item In .SelectedItems
AltPath2 = item
fso.CopyFile Source:=AltPath2, Destination:=NewPath
Next
End With
End If
'End If
End Sub
It will simple copy (all) files you select in the Dialog. Not understanding why necessary a loop as your code tried...
I want to retrieve data from multiple Excel workbooks in a folder.
The files are not opened.
The workbooks are called: Business Case (1), Business Case (2)... (incrementally growing until ~50).
I need the data to do business analysis, and evaluate potential ideas.
I got it working until file nr. 11 with the "Indirect" function. It won't retrieve more data after 10+; so I started looking at VBA.
The first problem I ran into with VBA, is that lopping through Excel files, looks like it requires a "fixed" path (e.g.: c:\Users\Bonkers\Desktop\Folder.....). I want the master-data-retrieval-book to work on other PCs, so the path of the folder, needs to be "not limited" to my PC.
Function ChooseFolder(strTitle As String, fDtype) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(fDtype)
With fldr
.Title = strTitle
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
ChooseFolder = sItem
Set fldr = Nothing
End Function
Sub datatransfer()
Dim FolderPath As String
Dim FilePath As String
Dim Filename As String
Dim targetfile As String
Dim wb1 As Workbook, wb2 As Workbook
targetfile = ChooseFolder("Please select the target file", msoFileDialogFilePicker)
FolderPath = ChooseFolder("Please select the Folder path", msoFileDialogFolderPicker)
FilePath = FolderPath & "\Business Case (*.xls*)"
Set wb2 = Workbooks.Open(targetfile) 'only need to open this once and leave open until execution is finished
Filename = Dir(FilePath)
Do While Filename <> "" ' need "<>" to say not equal to nothing
wb2.Worksheets.Add After:=wb2.Worksheets(wb2.Worksheets.Count) 'add new sheet to paste data in target book
Set wb1 = Workbooks.Open(FolderPath & "\" & Filename)
Dim lastrow As Long, lastcolumn As Long
With wb1.Worksheets(1) 'best to qualify all objects and work directly with them
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row
lastcolumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
'pretty sure you want to add this A1, since it's a new blank sheet
.Range(.Cells(2, 1), .Cells(lastrow, lastcolumn)).Copy _
Destination:=wb2.Worksheets(wb2.Worksheets.Count).Range("A1")
End With
wb1.Close False 'assume no need to save changes to workbook you copied data from
Filename = Dir
Loop
wb2.Close True 'no close and save master file
End Sub
If you need to dynamically set the files folder and the target file you can use the next adapted function:
Function ChooseFolder(strTitle As String, fDtype) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(fDtype)
With fldr
.Title = strTitle
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
ChooseFolder = sItem
Set fldr = Nothing
End Function
Then, in the processing Sub you may call it in the next way:
targetfile = ChooseFolder("Please select the target file", msoFileDialogFilePicker)
FolderPath = ChooseFolder("Please select the Folder path", msoFileDialogFolderPicker)
FilePath = folderPath & "\Business Case (*.xls*"
Edited:
Please, use this updated code. It will copy all the range as it is. Since, I do not know if the content of the all involved workbooks looks the same, I tried designing the code to behave as for the similar structures:
Sub datatransfer()
Dim FolderPath As String, FilePath As String, Filename As String, targetfile As String
Dim wb1 As Workbook, wb2 As Workbook, astrow As Long, lastcolumn As Long
FolderPath = ChooseFolder("Please select the Folder path", msoFileDialogFolderPicker)
targetfile = ChooseFolder("Please select the target file", msoFileDialogFilePicker)
FilePath = FolderPath & "\Business Case (*.xls*" 'you wrongly copied this line...
Set wb2 = Workbooks.Open(targetfile)
Filename = Dir(FilePath)
Do While Filename <> ""
wb2.Worksheets.Add After:=wb2.Worksheets(wb2.Worksheets.Count) 'add new sheet to paste data in target book
Set wb1 = Workbooks.Open(FolderPath & "\" & Filename)
With wb1.Worksheets(1) 'best to qualify all objects and work directly with them
lastrow = .UsedRange.Rows.Count + .UsedRange.Row
lastcolumn = .UsedRange.Columns.Count + .UsedRange.Column
.Range(.Cells(2, 1), .Cells(lastrow, lastcolumn)).Copy _
Destination:=wb2.Worksheets(wb2.Worksheets.Count).Range("A2")
End With
wb1.Close False 'assume no need to save changes to workbook you copied data from
Filename = Dir
Loop
wb2.Close True 'no close and save master file
End Sub
Please, test it and send some feedback.
I need to open multiple txt files from same folder and copy its contents to a single excel file (like a template) to modify the values and then, I need to copy the modified values from excel to txt files. How can we do this VBA automation? any reply would be helpful.
You can open a file by using the following method (found there, adapt it!)
Sub OpenAndImportTxtFile()
Dim wbI As Workbook, wbO As Workbook
Dim wsI As Worksheet
Set wbI = ThisWorkbook
Set wsI = wbI.Sheets("Sheet1") '<~~ Sheet where you want to import
Set wbO = Workbooks.Open("path and name of your file")
wbO.Sheets(1).Cells.Copy wsI.Cells
wbO.Close SaveChanges:=False
End Sub
And export your sheet with the following method (found there)
Sub SaveFile()
Dim ans As Long
Dim sSaveAsFilePath As String
On Error GoTo ErrHandler:
sSaveAsFilePath = "path and name of your file"
If Dir(sSaveAsFilePath) <> "" Then
ans = MsgBox("File " & sSaveAsFilePath & " exists. Overwrite?", vbYesNo + vbExclamation)
If ans <> vbYes Then
Exit Sub
Else
Kill sSaveAsFilePath
End If
End If
Sheet1.Copy '//Copy sheet to new workbook
ActiveWorkbook.SaveAs sSaveAsFilePath, xlTextWindows '//Save as text (tab delimited) file
If ActiveWorkbook.Name <> ThisWorkbook.Name Then '//Double sure we don't close this workbook
ActiveWorkbook.Close False
End If
My_Exit:
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume My_Exit
End Sub
Call them with
OpenAndImportTxtFile
SaveFile
There are pretty good guides I used to do the same work like you.
For Text to Excel:
http://www.excel-easy.com/vba/examples/read-data-from-text-file.html
vba: Importing text file into excel sheet
For Excel to Text:
http://www.excel-easy.com/vba/examples/write-data-to-text-file.html
Good luck
It sounds like you want to merge all text files into one single file. How about this option?
Sub CombineTextFiles()
Dim lFile As Long
Dim sFile As String
Dim vNewFile As Variant
Dim sPath As String
Dim sTxt As String
Dim sLine As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show Then
sPath = .SelectedItems(1)
If Right(sPath, 1) <> Application.PathSeparator Then
sPath = sPath & Application.PathSeparator
End If
Else
'Path cancelled, exit
Exit Sub
End If
End With
vNewFile = Application.GetSaveAsFilename("CombinedFile.txt", "Text files (*.txt), *.txt", , "Please enter the combined filename.")
If TypeName(vNewFile) = "Boolean" Then Exit Sub
sFile = Dir(sPath & "*.txt")
Do While Len(sFile) > 0
lFile = FreeFile
Open CStr(sFile) For Input As #lFile
Do Until EOF(lFile)
Line Input #1, sLine
sTxt = sTxt & vbNewLine & sLine
Loop
Close lFile
sFile = Dir()
Loop
lFile = FreeFile
Open CStr(vNewFile) For Output As #lFile
Print #lFile, sTxt
Close lFile
End Sub
I am trying to copy a sheet from one file and then paste it to an established tab in about 6 files in an established folder. I have this code, but it only works for the first file in the folder. It is also creating a blank workbook for some reason. Any suggestions?
Sub LoopThroughFiles()
Dim wbk As Workbook
Dim Filename As String
Dim FirstFile As String
Dim FileDirectory As String
Dim x As Workbook
Set x = Workbooks.Open("test.xlsx")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder"
Exit Sub
Else
FileDirectory = .SelectedItems(1) & "\"
End If
End With
Set wbk = Workbooks.Add
Filename = Dir(FileDirectory)
FirstFile = Filename
Do Until Filename = ""
Dim new_wb As Workbook
Set new_wb = Workbooks.Open(FileDirectory & Filename)
If FirstFile = Filename Then
x.Sheets("report").UsedRange.Copy
new_wb.Sheets("roster").Range("a1").PasteSpecial
End If
new_wb.Close savechanges:=True
Filename = Dir
Loop
MsgBox "All store totals have been added"
End Sub
Sub LoopThroughFiles_Paste_Roster()
Dim wbk As Workbook 'New workbook the data is added to
Dim Filename As String
Dim FirstFile As String
Dim FileDirectory As String
Dim x As Workbook
Dim y As Workbook
Set x = Workbooks.Open("Copy Doc 1")
Set y = Workbooks.Open("Copy Doc 2")
'display the folder picker dialog box so user can select a folder
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 0 Then
MsgBox "You did not select a folder"
Exit Sub
Else
FileDirectory = .SelectedItems(1) & "\"
End If
End With
'retrieve the name of the first file in the folder using Dir
Filename = Dir(FileDirectory)
FirstFile = Filename
'Loop through all the files in the folder
'open the file
Do Until Filename = ""
Set wbk = Workbooks.Open(FileDirectory & Filename, UpdateLinks:=False, Password:="Password123")
With wbk
x.Sheets("report").UsedRange.Copy
wbk.Sheets("roster").Range("a1").PasteSpecial
y.Sheets("Setup").UsedRange.Copy
wbk.Sheets("PTO Taken and Req").Range("a1").PasteSpecial
End With
'save and close the file
'get the next file in the folder
wbk.Close savechanges:=True
Filename = Dir
Loop
MsgBox "All pages have been updated"
End Sub