I have this code that gets the filenames on the selected directories.
Sub browsefile()
Dim file As Variant
Dim i As Integer
Dim lRow As Long
Set main = ThisWorkbook.Sheets("Main")
file = Application.GetOpenFilename("All Files, *.*", , "Select File", , True)
For i = 1 To UBound(file)
lRow = Cells(Rows.Count, 15).End(xlUp).Row
lRow = lRow + 1
ThisWorkbook.Sheets("Main").Range("O" & lRow).Value = GetFileName(CStr(file(i)))
Next i
End Sub
Function GetFileName(filespec As String)
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
GetFileName = fso.GetFileName(filespec)
End Function
Once I've selected the files, I have to put it in Column O. I have tried using .FullName but is not applicable in this area or maybe I've just misused it. Then later this will be send as attached file in an email in outlook.
By the way, I've got some of its code here.
Any help?
In Outlook include attachments with Attachments.Add
Private Sub browsefile_Att()
' Multiselect = False so file is not an array
' Dim file As Variant
Dim file As String
Dim lRow As Long
Dim main As Worksheet
Dim olOlk As Object
Dim olNewmail As Object
Set main = ThisWorkbook.Sheets("Main")
' Multiselect = False so file is not an array
file = Application.GetOpenFilename("All Files, *.*", , "Select File", , False)
lRow = Cells(Rows.Count, 15).End(xlUp).Row
lRow = lRow + 1
ThisWorkbook.Sheets("Main").Range("O" & lRow).Value = file
Set olOlk = CreateObject("Outlook.Application")
Set olNewmail = olOlk.CreateItem(olMailItem)
olNewmail.Attachments.Add file
olNewmail.Display
ExitRoutine:
Set olNewmail = Nothing
Set olOlk = Nothing
End Sub
I assume you are trying to obtain the full path to the file that you have selected. Application.GetOpenFilename already returns you that and hence, there is no need to reprocess your file with GetFileName function?
Changing
ThisWorkbook.Sheets("Main").Range("O" & lRow).Value = GetFileName(CStr(file(i)))
To
ThisWorkbook.Sheets("Main").Range("O" & lRow).Value = CStr(file(i))
should work assuming i have understood your question correctly. Hope this helps!
Related
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
'...
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
)
Please help with the code for copying files one by one to the destination folder. I tried with "for Each loop but it is copying all the files at once to the destination folder. I am new to to vba and would be helpful if someone could crack the code for me. thanks in advance. here's the code i have managed to come up with.
I am getting run time error 53, File not found,e highlighting the below syntax.
FSO.movefile Source:="C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro\" & Fname, Destination:="C:\Users\wazeer.ahamed\Documents\TcktIDfolder\" & Fname
Sub Example1()
'Extracting file names Dim objFSO As Object Dim objFolder As Object Dim newobjFile As Object
Dim lastID As Long Dim myRRange As Range Dim Maxvalue As Integer
Dim sFolder As String Dim dFolder As String
Sub Example1()
'Extracting file names
Dim FSO
Dim objFolder As Object
Dim newobjFile As Object
Dim FromDir As String
Dim ToDir As String
Dim lastID As Long
Dim myRRange As Range
Dim Maxvalue As Integer
Dim Fname As String
FromDir = "C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro\"
ToDir = "C:\Users\wazeer.ahamed\Documents\TcktIDfolder\"
Fname = Dir(FromDir)
If Len(FromDir) = 0 Then
MsgBox "No files"
Exit Sub
End If
Set myRange = Worksheets("Sheet1").Range("C:C")
Maxvalue = Application.WorksheetFunction.Max(myRange)
lastID = Maxvalue
'finding the next availabe row
erow = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
'Extracting file names
'Create an instance of the FileSystemObject
Set FSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = FSO.GetFolder("C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro")
'loops through each file in the directory and prints their names and path
For Each newobjFile In objFolder.Files
'print file name
Cells(erow, 1) = Fname
'print file path
Cells(erow, 2) = newobjFile.Path
'PrintUniqueID
Cells(erow, 3) = lastID + 1
FSO.movefile Source:="C:\Users\wazeer.ahamed\Documents\Outlookemails_Macro\" & Fname, Destination:="C:\Users\wazeer.ahamed\Documents\TcktIDfolder\" & Fname
Cells(erow, 5) = "file succesfully copied"
Next newobjFile
Set FSO = Nothing
Set newobjFile = Nothing
Set objFolder = Nothing
End Sub
I think that the code can be more simple and dynamic if you play with your own excel file.
Use "A1" range to put the source folder.
Use "B:B" range to put the
name of the files.
Use "C:C" range to concatenate the previous
columns.
Use "D1" range to put the destination folder.
Sub copyFiles()
'Macro for copy files
'Set variable
Dim source As String
Dim destination As String
Dim x As Integer
Dim destinationNumber As Integer
destinationNumber = WorksheetFunction.CountA(ThisWorkbook.Sheets("Sheet1").Range("C:C"))
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Create the folder if not exist
If Dir(ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("Sheet1").Range("D1"), 16) = "" Then
MkDir ThisWorkbook.Path & "\" & ThisWorkbook.Sheets("Sheet1").Range("D1")
End If
'Run the loop to copy all the files
For x = 1 To destinationNumber
source = ThisWorkbook.Sheets("Sheet1").Range("C" & x)
destination = ThisWorkbook.Sheets("Sheet1").Range("D1")
FileCopy source, destination
Next x
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
With this you can change the folders' paths and file names whenever you want. I've used FileCopy to preserve your files in the source but if you need to delete it's better use other method.
I want to move files to another folder from an Excel file (listfiles.xlsx) which contains paths of files in column A. The code below didn't work for me, can you help me please?
Sub movefile1()
Dim fso As FileSystemObject
Dim i As Long
Dim worksh As Worksheet
Dim workboo As Workbook
Set fso = CreateObject("scripting.filesystemobject")
Destination = "C:\Users\Desktop\Folder"
Set workboo = Workbooks.Open("C:\Users\TOSHIBA\Desktop\list_files.xlsx")
Set worksh = Worksheets("Listing")
numRows = worksh.Range("A" & Rows.Count).End(xlUp).Row
workboo.Windows(1).Visible = False
For i = 2 To numRows
Filepath = worksh.Range("A" & i).Value
fso.CopyFile Filepath, Destination
Next
End Sub
I changed the code but the fso.CopyFile Filepath, Destination does not work. They say permission refused
Place the line numRows = .Range("A" & .Rows.Count).End(xlUp).Row before the loop, otherwise the loop won't be executed at all
I have a file name of a pdf that I want to search for in a folder on a shared network drive \\Share\Projects. The pdf will be in one of the subfolders under projects. I then want to return the entire file path of the pdf into a cell (eg \\Share\Projects\Subfolder\Another subfolder\thisone.pdf).
I have started the code but can't figure out how to search a file system:
Sub InsertPath()
Dim PONumber As String
PONumber = InputBox("PO Number:", "PO Number")
'search for order
Dim myFolder As Folder
Dim myFile As File
'This bit doesn't work
Set myFolder = "\\Share\Projects"
For Each myFile In myFolder.Files
If myFile.Name = "PO" & PONumber & ".pdf" Then
'I have absolutely no idea how to do this bit
End If
Next
End Sub
Am I on the right track or is my code completely wrong?
get list of subdirs in vba
slighly modified the above post.
Public Arr() As String
Public Counter As Long
Sub LoopThroughFilePaths()
Dim myArr
Dim i As Long
Dim j As Long
Dim MyFile As String
Const strPath As String = "C:\Personal\" ' change it as per your needs
myArr = GetSubFolders(strPath)
Application.ScreenUpdating = False
Range("A1:B1") = Array("text file", "path")
For j = LBound(Arr) To UBound(Arr)
MyFile = Dir(myArr(j) & "\*.pdf")
Do While Len(MyFile) <> 0
i = i + 1
Cells(i, 1) = MyFile
Cells(i, 2) = myArr(j)
MyFile = Dir
Loop
Next j
Application.ScreenUpdating = True
End Sub
Function GetSubFolders(RootPath As String)
Dim fso As Object
Dim fld As Object
Dim sf As Object
Dim myArr
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(RootPath)
For Each sf In fld.SUBFOLDERS
Counter = Counter + 1
ReDim Preserve Arr(Counter)
Arr(Counter) = sf.Path
myArr = GetSubFolders(sf.Path)
Next
GetSubFolders = Arr
Set sf = Nothing
Set fld = Nothing
Set fso = Nothing
End Function
Well, your folder declaration isn't set against a filesystemobject so it can't find the folder. And because it's a network location, you may need to map a network drive first so that it's a secure link.
So here's an updated version of your code.
EDIT - to OP's conditions.
Dim PONumber As String
Sub InsertPath()
PONumber = InputBox("PO Number:", "PO Number")
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim Servershare As String
ServerShare = "S:\"
Dim Directory As Object
Set Directory = fso.GetFolder(ServerShare)
Subfolderstructure Directory
End Sub
Function Subfolderstructure(Directory As Object)
For Each oFldr in Directory.SubFolders
For Each FileName In oFldr.Files
If FileName.Name = "PO" & PONumber & ".pdf" Then
sheets("Sheet1").range("A1").value = ServerShare & "\PO" & PONumber & ".pdf"
Exit For
End If
Next
Dim sbfldrs : Set sbfldrs = ofldr.SubFolders
If isarray(sbfldrs) then
Subfolderstructure ofldr
End if
Next
'Cleanup
Set FileName = Nothing
Set Directory = Nothing
Set fso = Nothing
End Function
I have not tested this code. Try it out and let me know how it works.