Browsing Main excel file and Save As directory path with use of Excel VBA - vba

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

Related

vba loop through files in folder and copy names if multiple conditions are met/not met

I would like to loop through a folder and copy all the names of the excelfiles which does not contain "string1" in A6, "string2" in B6, "string3" in C6, "string4" in D6. Note all the conditions should be true (a AND statement).
The cells which should be tested are located in sheet 3, which is called "ProjectOperation".
The following code copy pase the filenames of all excel in a specific folder, however I have a hard time implementing the conditions. Please help.
Option Explicit
Sub SubDirList() 'Excel VBA process to loop through directories listing files
Dim sname As Variant
Dim sfil(1 To 1) As String
sfil(1) = "C:\Users\test" 'Change this path to suit.
For Each sname In sfil()
SelectFiles sname
Next sname
End Sub
Private Sub SelectFiles(sPath) 'Excel VBA to show file path name.
Dim Folder As Object
Dim file As Object
Dim fldr
Dim oFSO As Object
Dim i As Integer
'For Each file In Folder
' If checknameExistens(Folder.Files) Then
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set Folder = oFSO.GetFolder(sPath)
i = 1
For Each fldr In Folder.SubFolders
SelectFiles fldr.Path
Next fldr
For Each file In Folder.Files
'If checknameExistens(Folder.Files) Then
Range("A6536").End(xlUp)(2).Value = file
i = i + 1
Next file
Set oFSO = Nothing
End Sub
The original code is from the following link: http://www.thesmallman.com/list-files-in-subdirectory/
First of all I changed the code which retrieves the files because it collects all file regardless if it is a excel file or not. I also changed it to a function which gives all the files back in a collection
Function SelectFiles(ByVal sPath As String, ByVal pattern As String) As Collection
Dim Folder As Object
Dim file As Object
Dim fldr
Dim oFSO As Object
Dim coll As New Collection
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set Folder = oFSO.GetFolder(sPath)
For Each fldr In Folder.SubFolders
SelectFiles fldr.path, pattern
Next fldr
For Each file In Folder.Files
If file.Name Like pattern Then
coll.Add file
End If
Next file
Set SelectFiles = coll
End Function
Then I used the following function to retrieve the contents of the files which you can find here resp. here
Private Function GetValue(path, file, sheet, ref)
' Retrieves a value from a closed workbook
Dim arg As String
' Make sure the file exists
If Right(path, 1) <> "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetValue = "File Not Found"
Exit Function
End If
' Create the argument
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)
' Execute an XLM macro
GetValue = ExecuteExcel4Macro(arg)
If IsError(GetValue) Then GetValue = ""
End Function
And this is the final result
Sub TestList()
Const SH_NAME = "ProjectOperation"
Dim sname As Variant
Dim coll As Collection
Dim s1 As String
Dim s2 As String
Dim s3 As String
Dim s4 As String
Dim i As Long
sname = "...." 'Change this path to suit.
Set coll = SelectFiles(sname, "*.xls*")
For i = 1 To coll.Count
s1 = GetValue(coll.Item(i).parentfolder, coll.Item(i).Name, SH_NAME, "A6")
s2 = GetValue(coll.Item(i).parentfolder, coll.Item(i).Name, SH_NAME, "B6")
s3 = GetValue(coll.Item(i).parentfolder, coll.Item(i).Name, SH_NAME, "C6")
s4 = GetValue(coll.Item(i).parentfolder, coll.Item(i).Name, SH_NAME, "D6")
If s1 = "string1" And s2 = "string2" And s3 = "string3" And s4 = "string4" Then
Debug.Print coll.Item(i).path
End If
Next
End Sub
I worked with your existing code and have just added an If statement inside your loop (as well as a couple of declarations of new variables). Because you are now working with two files you need to properly reference the workbook and sheet whenever you refer to a range.
'...
Dim wb As Workbook, ws As Worksheet
Application.ScreenUpdating = False
For Each file In Folder.Files
Set wb = Workbooks.Open(file)
Set ws = wb.Sheets("ProjectOperation")
If ws.Range("A6").Value = "string1" And ws.Range("B6").Value = "string2" And _
ws.Range("c6").Value = "string3" And ws.Range("D6").Value = "string4" Then
ThisWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp)(2).Value = file 'workbook/sheet references may need changing
i = i + 1
End If
wb.Close False
Next file
Application.ScreenUpdating = True
'...

Excel VBA Workbook Printout Method

I am writing a VBA macro to convert excel workbooks to PDF.
The wkb.PrintOut method works fine for some excel files. But for the others, it will print the first worksheet to the file name I supplied, and prompt me for the file name to save for the remaining worksheets.
Why does the PrintOut function behaves such a way? How do I let it print the entire workbook into a single file name I set?
Public Sub ConvertToPDF()
Dim ws As Worksheet
Dim inputQueue As Collection
Dim outputQueue As Collection
Dim r As Integer, c As Integer
Dim objFSO As FileSystemObject
Dim objInputFolder As Folder
Dim objOutputFolder As Folder
Dim objInputFile As File
Dim fileExt As String
Set ws = Worksheets("XLPrint")
Set objFSO = New FileSystemObject
Set inputQueue = New Collection
Set outputQueue = New Collection
Application.ActivePrinter = "Microsoft Print to PDF on Ne02:"
Application.DisplayAlerts = False
r = ws.Range("folder_name").Row + 1
c = ws.Range("folder_name").Column
ClearCollection inputQueue
ClearCollection outputQueue
While (ws.Cells(r, c).Value <> "")
inputQueue.Add objFSO.GetFolder(ws.Cells(r, c).Value)
outputQueue.Add objFSO.GetFolder(ws.Cells(r, c + 1).Value)
r = r + 1
Wend
Application.ScreenUpdating = False
Do While inputQueue.Count > 0
Set objInputFolder = inputQueue(1)
inputQueue.Remove 1
Set objOutputFolder = outputQueue(1)
outputQueue.Remove 1
For Each objInputFile In objInputFolder.Files
fileExt = Mid(objInputFile.ShortName, InStr(objInputFile.ShortName, ".") + 1)
Select Case UCase(fileExt)
Case "XLSX", "XLSM", "XLS"
Call PrintXLToPDF(objInputFile, objOutputFolder)
Case "DOCX", "DOC"
Call PrintWordToPDF(objInputFile, objOutputFolder)
End Select
Next objInputFile
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Set objFSO = Nothing
Set ws = Nothing
Set inputQueue = Nothing
Set outputQueue = Nothing
MsgBox "Done"
End Sub
Public Sub PrintXLToPDF(ByVal objInputXL As File, ByVal objOutputFolder As Folder)
Dim wkb As Workbook
Dim outputFileName As String
Set wkb = Workbooks.Open(objInputXL.Path)
outputFileName = objOutputFolder.ShortPath & "\" & Mid(objInputXL.Name, 1, InStr(objInputXL.Name, ".") - 1) & ".pdf"
wkb.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False, PrToFileName:=outputFileName, ActivePrinter:="Microsoft Print to PDF on Ne02:"
wkb.Close SaveChanges:=False
Set wkb = Nothing
End Sub
Try just saving it directly as PDF instead of printing:
wkb.ExportAsFixedFormat Type:=xlTypePDF, Filename:=outputFileName, Quality:=xlQualityStandard
Many thanks
I combined the Plagon's answer and the answer of the
HackSlash and my problem was solved
The problem is solved when yuo save the Woorkbook (ActiveWorkbook.Save) and then use the line suggested by HackSlash (wkb.ExportAsFixedFormat Type:=xlTypePDF, Filename:=outputFileName, Quality:=xlQualityStandard
)

VBA Excel: for each results into cells? counter not working?

I´m creating a macro that crawls into subfolders and retrieve the name of some files. I used code from this answer to another question and works fine to get the results into the immediate window, but I want to get them into cells, as a list. What I get is just the result of the first iteration.
What I´m trying to do might be obvious, but I swear I tried and couldn´t find the answer by myself. For the record, I´m just starting to code.
My code here. The important part comes at the end, in Sub ListFiles(fld As Object, Mask As String).
Option Explicit
Sub Retrieve_Info()
Dim strPath As Variant
Dim pasta_destino As Range
Dim fle As String
Dim fso As Object 'FileSystemObject
Dim fldStart As Object 'Folder
Dim fld As Object 'Folder
Dim fl As Object 'File
Dim Mask As String
Set pasta_destino = ThisWorkbook.Worksheets("VINCULATOR").Range("pasta_destino")
strPath = Application.GetOpenFilename _
(Title:="Selecione o arquivo.xlsx", _
FileFilter:="Excel Files *.xlsx* (*.xlsx*),")
If Not strPath = False Then
pasta_destino = strPath
fle = Dir(strPath)
Set fso = CreateObject("scripting.FileSystemObject") ' late binding
'Set fso = New FileSystemObject 'or use early binding (also replace Object types)
Set fldStart = fso.GetFolder(Replace(strPath, fle, ""))
Mask = "*.xlsx"
For Each fld In fldStart.SubFolders
ListFiles fld, Mask
Next
End If
End Sub
Sub ListFiles(fld As Object, Mask As String)
Dim fl As Object 'File
Dim vrow As Integer
Dim vinculadas As Range
Dim n_vinc As Range
Set vinculadas = ThisWorkbook.Worksheets("VINCULATOR").Range("vinculadas")
Set n_vinc = ThisWorkbook.Worksheets("VINCULATOR").Range("n_vinc")
vrow = 0
For Each fl In fld.Files
If fl.Name Like Mask And InStr(fl.Name, "completo") = 0 Then
vrow = vrow + 1
vinculadas.Cells(vrow, 1) = fld.Path & "\" & fl.Name
End If
Next
n_vinc = vrow
End Sub
Please, help!
I have taken a slightly different approach which might be easier for you to follow in addition to executing faster. Please try this.
Sub SpecifyFolder()
' 10 Dec 2017
Dim Fd As FileDialog
Dim PathName As String
Dim Fso As Object
Dim Fold As Object, SubFold As Object
Dim i As Long
Set Fd = Application.FileDialog(msoFileDialogFolderPicker)
With Fd
.ButtonName = "Select"
.InitialView = msoFileDialogViewList
.InitialFileName = "C:\My Documents\" ' set as required
.Show
If .SelectedItems.Count Then
PathName = .SelectedItems(1)
Else
Exit Sub ' user cancelled
End If
End With
Set Fd = Nothing
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Fold = Fso.GetFolder(PathName)
ListFiles Fold, "*.xlsx"
For Each SubFold In Fold.SubFolders
ListFiles SubFold, "*.xlsx"
Next SubFold
Set Fso = Nothing
End Sub
Sub ListFiles(Fold As Object, _
Mask As String)
' 10 Dec 2017
Dim Fun() As String ' file list
Dim Rng As Range
Dim Fn As String ' file name
Dim i As Long ' array index
ReDim Fun(1 To 1000) ' maximum number of expected files in one folder
Fn = Dir(Fold.Path & "\")
Do While Len(Fn)
If Fn Like Mask And InStr(Fn, "completo") = 0 Then
i = i + 1
Fun(i) = Fold.Path & "\" & Fn
End If
Fn = Dir
Loop
If i Then
ReDim Preserve Fun(1 To i)
With ThisWorkbook.Worksheets("VINCULATOR")
' specify the column in which to write (here "C")
i = .Cells(.Rows.Count, "C").End(xlUp).Row
Set Rng = .Cells(i + 1, "C").Resize(UBound(Fun), 1)
Application.ScreenUpdating = False
Rng.Value = Application.Transpose(Fun)
Application.ScreenUpdating = True
End With
End If
End Sub
As you see, I have dispensed with specifying a target range, just the sheet and the column (I chose column C; please change as required in the ListFiles sub). Note that the code appends new lists to the existing content of the indicated column.
There are two things the code doesn't do to my entire satisfaction. One, it doesn't write to the first row of an empty column C. Instead, it leaves the first row blank. You might actually like that. Two, It doesn't do sub-subfolders. File names are extracted only from the selected folder and its immediate subfolders. Additional programming would be required for either additional feature, if required.
Finally, I admit that I didn't test for correct transfer of the lists to the worksheet. I think it works correctly but you should check that the first and last names are listed in your worksheet column. They are extracted from the folder but perhaps their omission when writing to the sheet would be a typical error to occur in this particular method.

VBA, Search in Subfolders

I am looking in the Folder for specific file in .docx and want to open it. I put the Name of X into Inputbox, go to Sheet Y, look on the next right cell of X and open this as Word (next cell right is an file in word I want to open). It is working, but the Problem is that the target Word Doc may be in multiples subfolders. Is there any quick way to search in These subfolder?
Private Sub CommandButton1_Click()
On Error GoTo ErrorHandling
Application.ScreenUpdating = False
Dim AppWD As Object
Dim SearchX As String
Dim SearchArea As Range
Dim Y As String
Dim sPath As String
sPath = "C:\Users\VS\Desktop\test"
SearchRule = InputBox("X")
Set SearchArea = Sheets("Look").Range("A:A").Find(what:=SearchX, _
LookIn:=xlFormulas, lookat:=xlWhole)
ActiveWindow.Visible = True
Target = SearchArea.Offset(0, 1).Value
Set AppWD = CreateObject("Word.Application")
AppWD.Visible = True
AppWD.documents.Open (sPath & "\" & Target & "." & "docx")
ErrorHandling: Exit Sub
End Sub
My take on searching throught subfolders
Sub searchSub()
Dim fso As FileSystemObject, fFile As File, fFolder As Folder
Dim fSubFolder As Folder, fPath As String, FileToSearch As String
Set fso = New FileSystemObject
FileToSearch = "SomeDocument.docx"
fPath = ThisWorkbook.Path
Set fFolder = fso.GetFolder(fPath)
For Each fFolder In fFolder.SubFolders
Set fSubFolder = fso.GetFolder(fFolder.Path)
For Each fFile In fSubFolder.Files
If fFile.Name = FileToSearch Then
'do something with file
End If
Next fFile
Next fFolder
End Sub

File loop is wrongfully skipping files

I have written the below code to loop through all the files in a directory and copy certain values from them and paste it back into the master file.
The problem that I am having is that the code never fully runs through all the files and I never get an error.
As shown in the picture the file names are depicted as 1 - #####, then 2 - ####, etc.
Sometimes there are multiple of the first number like in the picture there are two 1 - ###'s but the end numbers are still different.
The problem is that instead of going by the actual numerical order the code is using only the first number and going from 1, 10, 11, 100 and completely skipping the rest.
Any ideas on how to solve this?
Sub ReadDataFromCloseFile()
On Error GoTo ErrHandler
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim FileType As String
Dim FilePath As String
FileType = "*.xlsm*" 'The file type to search for
FilePath = "\\filepath\" 'The folder to search
Dim src As Workbook
Dim OutputCol As Variant
Dim Curr_File As Variant
OutputCol = 9 'The first row of the active sheet to start writing to
Curr_File = Dir(FilePath & FileType)
Do Until Curr_File = ""
' OPEN THE SOURCE EXCEL WORKBOOK IN "READ ONLY MODE".
Set src = Workbooks.Open(FilePath & Curr_File, True, True)
Sheets("Reporting").Range("I7:I750").Copy
Workbooks("Master.xlsm").Activate
Sheets("Sheet2").Select
Sheets("Sheet2").Cells(4, OutputCol).Select
ActiveCell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
OutputCol = OutputCol + 1
' CLOSE THE SOURCE FILE.
src.Close False ' FALSE - DON'T SAVE THE SOURCE FILE.
Curr_File = Dir
Loop
Set src = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Filepath
I've no idea why it doesn't open the 2 to 9 files. This version puts all the file paths into a collection and then steps through the collection.
It also does away with selecting the sheets before pasting, etc.
Sub ReadDataFromCloseFile()
Dim FileType As String
Dim FilePath As String
Dim colFiles As Collection
Dim src As Workbook
Dim tgt As Workbook
Dim OutputCol As Variant
Dim Curr_File As Variant
Set colFiles = New Collection
FileType = "*.xlsm*" 'The file type to search for
FilePath = "\\filepath\" 'The folder to search
EnumerateFiles FilePath, FileType, colFiles
OutputCol = 9 'The first row of the active sheet to start writing to
'If Master.xlsm is the book containing this code then use '=ThisWorkbook'
Set tgt = Workbooks("Master.xlsm")
For Each Curr_File In colFiles
Set src = Workbooks.Open(Curr_File, True, True)
src.Worksheets("Reporting").Range("I7:I750").Copy
tgt.Worksheets("Sheet2").Cells(4, OutputCol).PasteSpecial xlPasteValuesAndNumberFormats
OutputCol = OutputCol + 1
src.Close False
Next Curr_File
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
It might be easier for you to loop through the files using the below loop.
Sub LoopFiles()
Dim FSO As New FileSystemObject
Dim Fldr As Folder
Dim Fl As File
'Loop through files in folder
For Each Fl In FSO.GetFolder(filePath).Files
'Check for file type
If Fl.Type = "Excel Macro-Enabled Workbook" Then
'Open file & do procedure
End If
Next
Set FSO = Nothing
End Sub
Try declaring your variable OutputCol as an integer and not a variant. If you know your data is always going to be a number, it's never a good idea to use a variant. It takes more resources to execute the code and you don't know all of the internal logic that is going on behind the scenes. It also gives you more control of the code's execution and probably won't give you headaches like this one. Only use a variant if you don't know what data you are going to output.
Hope this helps!