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
Related
New to VBA and initially my problem was to copy text in CSV file into string and then ultimately to a master workbook. I used the below code which works perfectly:
Sub Compiler()
Dim handle As Integer
Dim wbDst As Workbook
Dim wsDst As Worksheet
Dim lLastRow As Long
Dim MyPath As String
Dim strFilename As String
handle = FreeFile
Set wbDst = ThisWorkbook
Set wsDst = wbDst.Worksheets("First Sheet")
lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1
Sheets("First Sheet").Columns(1).NumberFormat = "#"
Sheets("First Sheet").Columns(2).NumberFormat = "#"
Sheets("First Sheet").Columns(3).NumberFormat = "#"
MyPath = "W:\Test Folder\"
strFilename = Dir(MyPath, vbNormal)
Do While strFilename <> ""
Dim buffer As String
Open MyPath & strFilename For Input As #handle
buffer = Input(LOF(handle), handle) '<-- reads the entire contents of the file to "buffer"
Close #handle
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText buffer
.PutInClipboard
End With
wsDst.Paste wsDst.Range("A" & lLastRow)
'Application.CutCopyMode = False
strFilename = Dir()
Loop
End Sub
However, for some reason, it only copy pastes some of the files and not others (or maybe it overwrites it?, point is some of the files are not copied in). Not sure why this is the case? Is it because there are some blank cells in files? To rectify this, i replaced all blank cells with 0 - didn't work. Is it because of different copy paste area? Don't know how to rectify that if this is the case
So after long investigation, i found out an impractical approach where if you paste in files that you need to copy one by one, It does the trick but it is inefficient. So just for a temp solution, i did the following where vba code copies in a file from a temp folder to the source folder, does its job of copy pasting to the master work book and then deletes the file that was copied in. For some reason, the code stops at the first even though it's a Do while loop. Not sure what's the problem here and what is most efficient approach here?
Sub ISINCompiler()
'Declare Variables
Dim FSO
Dim MyPath As String
Dim strFilename As String
Dim sFile As String
Dim sSFolder As String
Dim sDFolder As String
Application.DisplayAlerts = False
MyPath = "C:\Users\Tomhardy\Desktop\ISIN-Compiler Temp\"
strFilename = Dir(MyPath, vbNormal)
'This is Your File Name which you want to Copy
'Change to match the destination folder path
sDFolder = "W:\Test Folder\"
'Create Object
Set FSO = CreateObject("Scripting.FileSystemObject")
'Checking If File Is Located in the Source Folder
Do While strFilename <> ""
If Not FSO.FileExists(MyPath & strFilename) Then
MsgBox "Specified File Not Found", vbInformation, "Not Found"
'Copying If the Same File is Not Located in the Destination Folder
ElseIf Not FSO.FileExists(sDFolder & strFilename) Then
FSO.CopyFile (MyPath & strFilename), sDFolder, True
ISINCompilerx2 '<-Copying and pasting in text
DeleteExample1 '<-Deleting the file after it has been copied in
Else
MsgBox "Specified File Already Exists In The Destination Folder",
vbExclamation, "File Already Exists"
End If
strFilename = Dir()
Loop
End Sub
Private Sub ISINCompilerx2()
Dim handle As Integer
Dim wbDst As Workbook
Dim wsDst As Worksheet
Dim lLastRow As Long
Dim someotherpath As String
Dim somestrFilename As String
handle = FreeFile
Set wbDst = ThisWorkbook
Set wsDst = wbDst.Worksheets("First Sheet")
lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1
Sheets("First Sheet").Columns(1).NumberFormat = "#"
Sheets("First Sheet").Columns(2).NumberFormat = "#"
Sheets("First Sheet").Columns(3).NumberFormat = "#"
someotherpath = "W:\Test Folder\"
somestrFilename = Dir(someotherpath, vbNormal)
Do While somestrFilename <> ""
Dim buffer As String
Open someotherpath & somestrFilename For Input As #handle
buffer = Input(LOF(handle), handle) '<-- reads the entire
contents of the file to "buffer"
Close #handle
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText buffer
.PutInClipboard
End With
wsDst.Paste wsDst.Range("A" & lLastRow)
Application.CutCopyMode = False
somestrFilename = Dir()
Loop
End Sub
Private Sub DeleteExample1()
On Error Resume Next
Kill "W:\Test Folder\*.*"
On Error GoTo 0
End Sub
new Code:
Sub ISINCompiler()
'Declare Variables
Dim FSO As Object
Dim MyPath As String
Dim strFilename As String
Dim f As Object
Dim sDFolder As String
Application.DisplayAlerts = False
MyPath = "C:\Users\Tomhardy\Desktop\ISIN-Compiler Temp\"
strFilename = Dir(MyPath, vbNormal)
'This is Your File Name which you want to Copy
'Change to match the destination folder path
sDFolder = "W:\Destination folder\"
' Create Object
Set FSO = CreateObject("Scripting.FileSystemObject")
'Checking If File Is Located in the Source Folder
For Each f In FSO.GetFolder(MyPath).Files
If Not FSO.FileExists(MyPath & strFilename) Then
MsgBox "Specified File Not Found", vbInformation, "Not Found"
'Copying If the Same File is Not Located in the Destination Folder
ElseIf Not FSO.FileExists(sDFolder & strFilename) Then
FSO.CopyFile (MyPath & strFilename), sDFolder, True
'ISINCompilerx2
'DeleteExample1
MsgBox "Specified File Copied Successfully", vbInformation, "Done!"
Else
MsgBox "Specified File Already Exists In The Destination Folder",
vbExclamation, "File Already Exists"
End If
Next f
Set f = Nothing
Set FSO = Nothing
End Sub
You can simplify your code;
Dim Filename As String
Dim lLastRow As Long
Dim wsDst As Worksheet
Set wsDst = ThisWorkbook.Worksheets("First Sheet")
Filename = Dir("W:\Test Folder\*.csv")
Do While Filename <> ""
Set wbSrce = Workbooks.Open(Filename)
lLastRow = wsDst.UsedRange.Rows.Count + 1
wbSrce.Sheets(1).UsedRange.Copy wsDst.Range("A" & lLastRow)
wbSrce.Close savechanges:=False
Filename = Dir
Loop
So i found out that Dir was the problem so i just removed dir in my main macro
Option Explicit
Public wbDst As Workbook
Public wsDst As Worksheet
Sub ISINCompiler()
'Declare Variables
Set wbDst = ThisWorkbook
Set wsDst = wbDst.Worksheets("First Sheet")
Dim i As Long
Dim myFSO As FileSystemObject
Dim xFolder As Scripting.Folder
Dim FSO As Object
Dim f
Dim MyPath As String
Dim sDFolder As String
Application.DisplayAlerts = False
sDFolder = "W:\Destination\"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set myFSO = New FileSystemObject
Set xFolder = myFSO.GetFolder("C:\Source")
'Checking If File Is Located in the Source Folder
For Each f In xFolder.Files
f.Copy sDFolder & f.Name
MsgBox "Specified File Copied Successfully", vbInformation, "Done!"
ISINCompilerx2
DeleteExample1
Next f
End Sub
Private Sub ISINCompilerx2()
Dim handle As Integer
Dim lLastRow As Long
Dim somePath As String
Dim someFilename As String
handle = FreeFile
lLastRow = wsDst.UsedRange.Rows(wsDst.UsedRange.Rows.Count).Row + 1
Sheets("First Sheet").Columns(1).NumberFormat = "#"
Sheets("First Sheet").Columns(2).NumberFormat = "#"
Sheets("First Sheet").Columns(3).NumberFormat = "#"
somePath = "W:\Destination\"
someFilename = Dir(somePath, vbNormal)
Dim buffer As String
Open somePath & someFilename For Input As #handle
buffer = Input(LOF(handle), handle) '<-- reads the entire contents of
the file to "buffer"
Close #handle
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText buffer
.PutInClipboard
End With
wsDst.Paste wsDst.Range("A" & lLastRow)
Application.CutCopyMode = False
End Sub
Private Sub DeleteExample1()
'You can use this to delete all the files in the folder Test
On Error Resume Next
Kill "W:\Destination\*.*"
On Error GoTo 0
End Sub
I have multiple word documents in a folder.
What I really want is to list the document names and check whether these docs incude some specified words.
I create two word documents for example to explain.
There are two documents, Doc A and Doc B, in a folder.
I want to list the file name Doc A and Doc B in the excel column A.
After listing the doc name in column A, I want to check whether specified words "classification" and "Statistics" are in the docs.
If these specified words in the document, it will mark in the excel. Please see below picture for the result I want.
I provide the code in the following:
Option Explicit
Private xRow As Long
Sub Get_MAIN_File_Names()
Dim fso As FileSystemObject
Dim xDirect As String
Dim xRootFolder As Folder
Dim DrawingNumb As String
Dim RevNumb As String
Dim rootFolderStr As String
Set fso = New FileSystemObject
xRow = 0
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select Main File"
.Show
'PROCESS ROOT FOLDER
If .SelectedItems.Count <> 0 Then
xDirect = .SelectedItems(1) & "\"
Set xRootFolder = fso.GetFolder(xDirect)
ProcessFolder fso, xRootFolder
End If
End With
End Sub
Private Sub ProcessFolder(fso As FileSystemObject, xFolder As Folder)
Dim xFiles As Files
Dim xFile As File
Dim xSubFolders As Folders
Dim xSubFolder As Folder
Dim xFileName As String
Dim objWordApplication As New Word.Application
Dim objWordDocument As Word.Document
Dim strFile As String
strFile = Dir(xFolder & "*.doc", vbNormal)
While strFile <> ""
With objWordApplication
Set objWordDocument = .Documents.Open(FileName:=xFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
Set xFiles = xFolder.Files
'Adding Column names
Cells(1, "A").Value = "Document Name"
Cells(1, "B").Value = "classification"
Cells(1, "C").Value = "Statistics"
'LOOPS THROUGH EACH FILE NAME IN FOLDER
For Each xFile In xFiles
'EXTRACT INFORMATION FROM FILE NAME, this part may not add
xFileName = xFile.Name
Set Docs = objWordDocument.Content
With Docs.Find
.ClearFormatting
.Text = "classification"
Wrap:=wdFindContinue
End With
With Docs.Find
.ClearFormatting
.Text = "Statistics"
Wrap:=wdFindContinue
End With
'INSERT INFO INTO EXCEL
ActiveCell.Offset(xRow, 0) = xFileName
'Below needs to add.
ActiveCell.Offset(xRow, 1) =
ActiveCell.Offset(xRow, 2) =
'Above needs to add.
xRow = xRow + 1
With objWordDocument
.Close
End With
Next xFile
Set xSubFolders = xFolder.SubFolders
For Each xSubFolder In xSubFolders
ProcessFolder fso, xSubFolder
Next xSubFolder
End Sub
Based on above code, it fails.
I think the problem is With Docs.Find.....; however, I'm not really sure about it.
Moreover, I do not know how to do this part.
'Below needs to add.
ActiveCell.Offset(xRow, 1) =
ActiveCell.Offset(xRow, 2) =
'Above needs to add.
Can any one help me edit the code?
Maybe this code will help you out, it does:
Assume you got a activesheet setup with the three headers there
Loop through .docx files in specified folder
Checks wordrange for specified tekst
Returns true or false and puts found or not found in appropriate cell
Sub LoopWordDocs()
Dim FLDR As String
Dim wDoc As Word.Document
Dim wRNG As Word.Range
Dim LR As Long, COL As Long
Dim WS As String
Dim wAPP As Word.Application
Dim WordWasNotRunning As Boolean
On Error Resume Next
Set wAPP = GetObject(, "Word.Application")
If Err Then
Set wAPP = New Word.Application
WordWasNotRunning = True
End If
On Error GoTo Err_Handler
WS = ThisWorkbook.ActiveSheet.Name
FLDR = "U:\Test\" 'Change directory accordingly
aDoc = Dir(FLDR & "*.docx") 'Change docx to .doc if you need
Do While aDoc <> ""
Set wDoc = Documents.Open(Filename:=FLDR & aDoc)
LR = Sheets(WS).Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets(WS).Cells(LR, 1) = aDoc
Set wRNG = wDoc.Range
For COL = 2 To 3 'It will loop through B1 and C1 to check if present in text
With wRNG.Find
.Text = Sheets(WS).Cells(1, COL).Text
.MatchCase = False
.MatchWholeWord = True
If wRNG.Find.Execute = True Then
Sheets(WS).Cells(LR, COL) = "V" 'Change V to your liking
Else
Sheets(WS).Cells(LR, COL) = "X" 'Change X to your liking
End If
End With
Next COL
wDoc.Close SaveChanges:=True
aDoc = Dir
Loop
Exit Sub
Err_Handler:
MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number
If WordWasNotRunning Then
wAPP.Quit
End If
End Sub
Note: You'll have to turn on Microsoft Word 14.0 Object Library for this to work
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 have a two codes. I would like the second code to perform the first code on all files in a directory. The first code works like a charm and does exactly what I need it to, this is that:
Sub STATTRANSFER()
' Transfers all STATS lines
Application.ScreenUpdating = False
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = "STATS"
Set f = Sheets(1)
Set e = Sheets("Stats")
Dim d
Dim j
Dim k
d = 1
j = 1
k = 1
Do Until IsEmpty(f.Range("A" & j))
If f.Range("A" & j) = "STATS" Then
e.Rows(d).Value = f.Rows(j).Value
d = d + 1
f.Rows(j).Delete
Else
j = j + 1
End If
Loop
Application.ScreenUpdating = True
End Sub
The second code looks like this:
Public Sub DataProcess()
Dim folderPath
Dim filename
Dim newfilename
Dim SavePath
Dim mySubFolder As Object
Dim mainFolder As Object
Dim WB As Workbook
Dim OrigWB As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim name1 As String
Dim name2 As String
Set OrigWB = ThisWorkbook
Set objFSO = CreateObject("Scripting.FileSystemObject")
folderPath = ActiveWorkbook.Path
Set mainFolder = objFSO.GetFolder(folderPath)
filename = Dir(folderPath & "*.csv")
Do While Len(filename) > 0
Set WB = Workbooks.Open(folderPath & filename)
Call STATTRANSFER
ActiveWorkbook.Close SaveChanges:=True
filename = Dir
Loop
For Each mySubFolder In mainFolder.SubFolders
filename = Dir(mySubFolder.Path & "\*.csv*")
Do While Len(filename) > 0
Set WB = Workbooks.Open(mySubFolder.Path & "\" & filename)
Call STATTRANSFER
ActiveWorkbook.Close SaveChanges:=True
filename = Dir
Loop
Next
End Sub
The second code does successfully loop through all of the folders and documents I want it to, however it performs my first code incorrectly. When I perform the first code on a sheet alone, it creates a new sheet called STATS then takes all lines from the first sheet that has the word STATS in column A and copies them to the new sheet, it then deletes the STATS lines out of the first sheet.
When I run it with the second code that goes through all the folders it doesn't work the same. I can see it create the sheet called STATS on my screen but then when it finishes and I open up on of the documents all the lines that have STATS in column A are on the first sheet, the STATS sheet is no longer there, and all the data that didn't have STATS in column A is gone. So I'm not sure what the problem is.
Keep your first sub as it is, replace your second sub with this:
Sub MM()
Dim file As Variant
Dim files As Variant
Dim WB As Excel.Workbook
files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & ActiveWorkbook.Path & "\*.csv"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
For Each file In files
Set WB = Workbooks.Open(file)
STATTRANSFER
WB.Close True
Set WB = Nothing
Next
End Sub
just as an remark: your code only runs thru the first level of sub folders. If you want to go thru all sub level folders, you have to use a recursive method like:
Private Sub test()
readFileSystem ("C:\Temp\")
End Sub
Private Sub readFileSystem(ByVal pFolder As String)
Dim oFSO As Object
Dim oFolder As Object
' create FSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
' get start folder
Set oFolder = oFSO.getFolder(pFolder)
' list folder content
listFolderContent oFolder
' destroy FSO
Set oFolder = Nothing
Set oFSO = Nothing
End Sub
Private Sub listFolderContent(ByVal pFolder As Object)
Dim oFile As Object
Dim oFolder As Object
' go thru all sub folders
For Each oFolder In pFolder.SubFolders
Debug.Print oFolder.Path
' do the recursion to list sub folder content
listFolderContent oFolder
Next
' list all files in that directory
For Each oFile In pFolder.Files
Debug.Print oFile.Path
Next
' destroy all objects
Set pFolder = Nothing
Set oFile = Nothing
Set oFolder = Nothing
End Sub
this is just an example and you have to call your first procedure of course still correct. So I would suggest to add a parameter to the first procedure where you can pass the workbook.
and BTW: always delcare your variables with datatype. Dim j will declare a VARIANT variable and not a Interger as you might want to have.
You see all STATS in the first sheet because you added an extra sheet to a CSV file and saved it. By definition, CSV file only saves and shows 1 sheet.
This modification to your code could solve your problem, as it calls itself to go through subfolders.
Try it.
Include your STATTRANSFER sub.
Public Sub DataProcess()
thisPath = ThisWorkbook.Path
process_folders (thisPath)
End Sub
Sub process_folders(thisPath)
Dim folderPath
Dim filename
Dim newfilename
Dim SavePath
Dim mySubFolder As Object
Dim mainFolder As Object
Dim WB As Workbook
Dim OrigWB As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim name1 As String
Dim name2 As String
Set OrigWB = ThisWorkbook
Set objFSO = CreateObject("Scripting.FileSystemObject")
folderPath = ActiveWorkbook.Path
Set mainFolder = objFSO.GetFolder(folderPath)
folderPath = ActiveWorkbook.Path
filename = Dir(folderPath & "\*.csv")
Do While Len(filename) > 0
Set WB = Workbooks.Open(folderPath & "\" & filename)
Call STATTRANSFER
'save file as Excel file !!!
ActiveWorkbook.SaveAs _
filename:=(folderPath & "\" & filename), _
FileFormat:=xlOpenXMLWorkbook, _
CreateBackup:=False
ActiveWorkbook.Close (False)
filename = Dir
Loop
'now with each subfolder
For Each subfolder In mainFolder.SubFolders
process_folders (subfolder)
Next
End Sub
The problem was that you can only save a .csv with one sheet on it. Now the code looks like this.
Sub NewDataProcess()
Dim file As Variant
Dim files As Variant
Dim wb As Excel.Workbook
files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & ActiveWorkbook.Path & "\*.csv"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
For Each file In files
Set wb = Workbooks.Open(file)
Call STATTRANSFER(wb)
newfilename = Replace(file, ".csv", ".xlsm")
wb.SaveAs filename:=newfilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
wb.Close SaveChanges:=False
Set wb = Nothing
Next
End Sub
Now I need a way to delete the old files if someone can help with that. I dont want the CSV file at all anymore
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.