I got this code from somewhere in the net, and it works fine for me. However my experience is not enough to run it in all subfolders of the main one ("C:\Folder\"). I would appreciate any suggestion.
Sub check()
Dim strFolder As String
Dim strFile As String
strFolder = "C:\Folder\"
strFile = Dir(strFolder & "*.*")
Do While Len(strFile) > 0
If InStr(strFile, "xxx") > 0 Then
Name strFolder & strFile As strFolder & Replace(strFile, "xxx", "yyy")
End If
strFile = Dir()
Loop
End Sub
You're much better off using the System.IO namespace(you'll need to add the Imports statement for it), as there is a Directories.GetFiles method that allows for an option to search AllDirectories within your specified folder
Imports System.IO;
Sub Check()
Dim strFolder As String = "C:\Folder\"
Dim strFiles() As String = Directory.GetFiles(strFolder, "*.*", SearchOption.AllDirectories)
For Each strFile As String In strFiles
If strFile.Contains("xxx") Then
File.Move(strFolder & strFile, strFolder & strFile.Replace("xxx", "yyy"))
End If
Next
End Sub
Related
I have many .doc documents located in many subfolders and I would like to covert them to .docx
I was opening each file and saving it but there are too many of them, so I thought there must be a better and a faster way. I found online some VBA code but none seem to work.
First VBA code:
Sub TranslateDocIntoDocx()
Dim objWordApplication As New Word.Application
Dim objWordDocument As Word.Document
Dim strFile As String
Dim strFolder As String
strFolder = "H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015"
strFile = Dir(strFolder & "*.doc", vbNormal)
While strFile <> ""
With objWordApplication
Set objWordDocument = .Documents.Open(FileName:=strFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With objWordDocument
.SaveAs FileName:=strFolder & Replace(strFile, "doc", "docx"), FileFormat:=16
.Close
End With
End With
strFile = Dir()
Wend
Set objWordDocument = Nothing
Set objWordApplication = Nothing
End Sub
Second VBA code:
Sub ConvertBatchToDOCX()
Dim sSourcePath As String
Dim sTargetPath As String
Dim sDocName As String
Dim docCurDoc As Document
Dim sNewDocName As String
' Looking in this path
sSourcePath = "H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015"
sTargetPath = "H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015"
' Look for first DOC file
sDocName = Dir(sSourcePath & "*.doc")
Do While sDocName <> ""
' Repeat as long as there are source files
'Only work on files where right-most characters are ".doc"
If Right(sDocName, 4) = ".doc" Then
' Open file
Set docCurDoc = Documents.Open(FileName:=sSourcePath & sDocName)
sNewDocName = Replace(sDocName, ".doc", ".docx")
With docCurDoc
.SaveAs FileName:=sTargetPath & sNewDocName, _
FileFormat:=wdFormatDocumentDefault
.Close SaveChanges:=wdDoNotSaveChanges
End With
End If
' Get next source file name
sDocName = Dir
Loop
MsgBox "Finished"
End Sub
Any help would be much appreciated!
In both routines you have the same small mistake: You miss a Backslash between the path and the filename. Your Dir-Command will see the following command and therefore doesn't find anything:
Dir("H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015*.doc", vbNormal
Either add the backslash at the end of the path definition:
strFolder = "H:\Vanhuspalvelut\Kotihoito\Tammelan_kotihoito\TURVALLISUUS\Pelastussuunnitelmaan_tuleva\TURVALLISUUS_SUUNNITELMA_2015\"
or put it into the Dir-command:
strFile = Dir(strFolder & "\*.doc", vbNormal)
On a monthly basis I have to aggregate daily files. The issue is I need the files to be in "TXT", but they are sent to me as "WRI".
I am able to do one file at a time if it is hardcoded with the following.
Name "C:\Users\John\Desktop\Folder1\SQLEXEC.WRI" As "C:\Users\John\Desktop\Folder1\SQLEXEC.TXT"
However, I want to be able to loop through the folder. But I am not sure how to change the code to allow it to loop.
Sub ConvertToTXT()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim strPath As String
Dim strFile As String
strPath = "C:\Users\John\Desktop\Folder1\" strFile = Dir(strPath & "*.wri")
Do While strFile <> ""
Name "C:\Users\John\Desktop\Folder1\SQLEXEC.WRI" As "C:\Users\John\Desktop\Folder1\SQLEXEC.TXT"
Loop
End Sub
I'd personally use the Scripting.FileSystemObject for this - it's much less prone to errors than manually building filepath strings. You'll need to add a reference to Microsoft Scripting Runtime:
Private Sub ConvertToTXT(filePath As String)
With New Scripting.FileSystemObject
Dim directory As Folder
Set directory = .GetFolder(filePath)
Dim target As File
For Each target In directory.Files
If LCase$(.GetExtensionName(target.Name)) = "wri" Then
Dim newName As String
newName = .BuildPath(filePath, .GetBaseName(target.Name)) & ".txt"
.MoveFile target.Path, newName
End If
Next
End With
End Sub
Call it by passing it the directory you want to perform the renaming in:
ConvertToTXT "C:\Users\John\Desktop\Folder1"
Note that is doesn't care if there's a trailing \ or not - this also works:
ConvertToTXT "C:\Users\John\Desktop\Folder1\"
Sub ConvertToTXT()
Const strPath As String = "C:\Users\John\Desktop\Folder1"
Dim strFile As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
strFile = Dir(strPath & "\" & "*.wri")
Do While strFile <> ""
Name strPath & "\" & strFile As strPath & "\" & Replace(strFile, ".wri", ".txt")
strFile = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
How can I programmatically create multiple levels of subfolders in VBA for MS Access? I know that MKDir only allows me to create one level, but I want to create 2 levels. The first level folder is based on the year the shipment took place, then the sub-level folder to that is the shipment number. The idea is to check and see if a folder(s) exists, and if not to create and open them.
Here is what I have so far:
Private Sub Command173_Click()
Const strParent = "S:\shipments\"
Dim strYearEntered As String
Dim strEntryNumber As String
Dim strFolder As String
Dim fso As Object
strYearEntered = Me.YearEntered
strEntryNumber = Me.EntryNum
strFolder = strParent & strYearEntered & "\" & strEntryNumber
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FOLDEREXISTS(strFolder) = False Then
fso.CreateFolder strFolder
End If
Shell "explorer.exe " & strFolder, vbNormalFocus
End Sub
Using this code gives me an error at the "fso.CreateFolder strFolder" line. This problem only occurred when I placed the "\" in the strFolder line, without the "\" it will only create one folder by cramming together the YearEntered and EntryNum values. Can anyone assist in this matter?
Thanks.
Private Sub Command173_Click()
Const strParent = "S:\shipments\"
Dim strYearEntered As String
Dim strEntryNumber As String
Dim strFolder As String
strYearEntered = Me.YearEntered
strEntryNumber = Me.EntryNum
strFolder = strParent & strYearEntered
If Dir(strFolder, vbDirectory) = "" then MkDir strFolder
strFolder = strFolder & "\" & strEntryNumber
If Dir(strFolder, vbDirectory) = "" then MkDir strFolder
Shell "explorer.exe " & strFolder, vbNormalFocus
End Sub
Edit:
As a recommendation of Still Learning I'm adding this article as a reference: Create Nested Directories
This answer maybe is too late but I will like to share with you this VBA util function where you can create subfolders recursive (multi-level) in a path.
Function createDirIfNotFound(ByVal sPath As String)
Dim iStart As Integer
Dim aDirs As Variant
Dim sCurDir As String
Dim i As Integer
If sPath <> "" Then
aDirs = Split(sPath, "\")
If Left(sPath, 2) = "\\" Then
iStart = 3
Else
iStart = 1
End If
sCurDir = Left(sPath, InStr(iStart, sPath, "\"))
For i = iStart To UBound(aDirs)
sCurDir = sCurDir & aDirs(i) & "\"
If Dir(sCurDir, vbDirectory) = vbNullString Then
mkDir sCurDir
End If
Next i
End If
End Function
And you can use it like this, and folders will be created deeply if not found:
createDirIfNotFound "c:\root\level1\level2"
I hope this helps somebody.
I created the following macro to open all ppt files in a certain map
Sub openAllPPT()
Dim strCurrentFile As String
Dim strFileSpec As String
strFileSpec = "C:\Documents and Settings\aa471714\Desktop\Nieuwe map*.ppt"
strCurrentFile = Dir$(strFileSpec)
While Len(strCurrentFile) > 0
Presentations.Open (strCurrentFile)
strCurrentFile = Dir$
Wend
End Sub
When I run it I do see anything opening up though. Anybody clue on what I'm missing?
Dir returns only the file name, not the full path to the file.
Try this instead:
Sub openAllPPT()
Dim strCurrentFile As String
Dim strFileSpec As String
Dim strDirectory As String
strDirectory = "C:\Documents and Settings\aa471714\Desktop\"
strFileSpec = "Nieuwe map*.ppt"
strCurrentFile = Dir$(strDirectory & strFileSpec)
While Len(strCurrentFile) > 0
'Presentations.Open (strDirectory & strCurrentFile)
Debug.Print strDirectory & strCurrentFile
strCurrentFile = Dir$
Wend
End Sub
I am creating a code in VBA in Access 2010 to link excel sheets and put them into tables in access. I keep getting an invalid outside of procedure at the strFile = Dir(StrPath &"*.xls") It keeps telling the the strPath is invalid outside procedure
Please help.
Option Compare Database
Option Explicit
'code will link to excel and pull site survey files into access tables
'Setting the path for the directory
Const strPath As String = "C:\Users\cparson\Documents\Survey_Eqpm\SiteSurveyData.xlsx"
'FileName
Dim strFile As String
'Array
Dim strFileList() As String
'File Number
Dim intFile As Integer
'Looping through the folder and building the file list
strFile = Dir(strPath & "*.xls")
While strFile <> ""
'adding files to the list
intFile = intFile + 1
ReDim Preserve strFileList(1 To intFile)
strFileList(intFile) = strFile
strFile = Dir()
Wend
'checking to see if files where found
If intFile = 0 Then
MsgBox "No Files Found"
Exit Sub
End If
'going through the files and linking them to access
For intFile = 1 To UBound(strFileList)
DoCmd.TransferSpreadsheet acLink, , _
strFileList(intFile), strPath & strFileList(intFile), True, "A5:J17"
Next
MsgBox UBound(strFileList) & "Files were linked"
End Sub
You have an End Sub but no procedure name?
Option Compare Database
Option Explicit
Const strPath As String = "C:\Users\cparson\Documents\Survey_Eqpm\SiteSurveyData.xlsx"
Dim strFile As String
Dim strFileList() As String
Dim intFile As Integer
Sub Sample() '<~~ You are missing this...
strFile = Dir(strPath & "*.xls")
'~~> Rest of your code
End Sub
I know this is an old question, but I came across it in a google search and realized that you already have the .xlsx extension in the strPath variable, but you add it to the string variable, strFile, also.
Const strPath As String = "C:\Users\cparson\Documents\Survey_Eqpm\SiteSurveyData.xlsx"
strFile = Dir(strPath & "*.xls")
I might be wrong, but just wanted to point it out.
You can try too ADO, it's a easy way in my opnion
YourConnObj.execute "SELECT * INTO YourTableName from [Excel 14.0;DATABASE=c:\temp\data copy.xlsx].[Sheet1]"