I'm wondering if there's a way that I can autoincrement file folder names based off of a value in a form. Basically, I need to create an empty folder within a previous folder with an autoincrementing number for future entries. My script works to create the folder in the right place, but I'm not sure how to make the title of the folder start with "1" then autoincrement for each future entry.
This is what I have right now. It doesn't work, but I think I may be onto something? I know I'll have to make the TimeDateTeam.value something static, or else each folder will be different and not be able to increment on number. I may just omit this entirely, and have the folder be titled "Test n", where n is the autoincremented number.
Dim filepath1 As String
Dim filepath2 As String
Dim i As Integer
filepath1 = Path2 & "\" & Me!TimeDateTeam.Value & "Test " & i
filepath2 = Path2 & "\" & Me!TimeDateTeam.Value & "Test " & i + 1
Dim fso As FileSystemObject
Set fso = New FileSystemObject
If fso.FileExists(filepath1) = True Then
MkDir filepath1
Else: MkDir filepath2
End If
I'm new to VBA and programming in general, and considered using a for loop and tacking "i" onto the end as long as i > 1, but I'm not sure the syntax to complete this. Any help or suggestions would be greatly appreciated. I am not set on using a for loop, so please help if you have another way!
Try this:
Sub Tester()
Const root As String = "C:\Tester\Test\"
Dim i As Integer
Dim fso As FileSystemObject
Set fso = New FileSystemObject
i = 1
Do While fso.FolderExists(root & "Subfolder" & i)
i = i + 1
Loop
fso.CreateFolder (root & "Subfolder" & i)
End Sub
This does not need a reference to the FileSystemObject.
Option Compare Database
Option Explicit
Sub sbMkDir()
Dim i As Integer
Dim s As String
s = CurrentProject.Path & "\folder"
For i = 1 To 3
MkDir s & i
Next i
End Sub
Works in Windows 10 and Microsoft 365
Related
Please go through my code, correct me where I am wrong, files are not moving from folder to folder.
Option Explicit
Sub MoveFiles()
Dim FSO As Object
Dim FromDir As String
Dim ToDir As String
Dim FExtension As String
Dim Fnames As String
FromDir = "C:\Users\B\Source Folder"
ToDir = "C:\Users\B\Destination Folder"
FExtension = "*.*"
Fnames = Dir(FromDir & FExtension)
If Len(Fnames) = 0 Then
MsgBox "No files or Files already moved" & FromDir
Exit Sub
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.MoveFile Source:=FromDir & FExtension, Destination:=ToDir
End Sub
Problem
You are missing a \ at the end of your FromDir which will separate the path from your filenames.
For your info: & is not really combining path and filename, but just concatenating two strings, so it never adds the \ itself.
Correction possibility 1
You can add it to the definition of FromDir:
FromDir = "C:\Users\B\Source Folder\"
Correction possibility 2
Add it to these lines of code dynamically:
Fnames = Dir(FromDir & "\" & FExtension)
FSO.MoveFile Source:=FromDir & "\" & FExtension, Destination:=ToDir
Another remark
You should also separate FromDir from the error text, like this:
MsgBox "No files or Files already moved: " & FromDir
I am trying to open a pdf file through MS Word, perform certain action such as evaluating calculations, printing the files, etc. and then proceed with closing the file. The error message I received is "Microsoft Excel is waiting for another application to complete an OLE action."
I have previously tried hyperlinkfollow and Shell MyPath & " " & MyFile, vbNormalFocus method, it doesn't work. I am still at the starting phase of opening the pdf files, please advice. Thanks!
Sub Extract_PDF_Data()
Dim mainData As String
Dim strFile As String
Dim Oldname As String
Dim Newname As String
Dim Folderpath As String
Dim s As String
Dim t As Excel.Range
Dim wd As New Word.Application
Dim mydoc As Word.Document
Folderpath = InputBox("Folder path: ")
Folderpath = Folderpath & "\"
strFile = Dir(Folderpath & "", vbNormal)
Do While Len(strFile) > 0
Oldname = Folderpath & strFile
Set wd = CreateObject("Word.Application")
Set mydoc = Word.Documents.Open(Filename:=Oldname, Format:="PDF Files",
ConfirmConversions:=False)
mainData = mydoc.Content.Text
mydoc.Close False
wd.Quit
strFile = Dir
Loop
End Sub
Don't us the New keyword in the line that declares the object variable. This will "block" the object variable - it causes the error when the code laters tries to instantiate it. This method can work in VB.NET but not in VBA.
Do it more like this:
Dim wd As Word.Application
Set wd = New Word.Application. 'Or use CreateObject
I think a combination of those three sources will lead to the answer:
How to open a pdf with Excel?
How to extract data from pdf using VBA?
How to open and print a pdf using VBA?
I think it will be something like this:
Sub Extract_PDF_Data()
Dim mainData As String
Dim strFile As String
Dim Oldname As String
Dim Newname As String
Dim Folderpath As String
Dim s As String
Dim t As Excel.Range
Dim Appshell As Variant
Dim ap As String
Dim Browsedir As Variant
Dim f As Variant
Dim KeyWord As String
' This is a suggestion, I use it because it is more convenient than copy-pasting folder paths
Dim FSO As Object
Set FSO = CreateObject("Scripting.Filesystemobject")
' Get Folder over user input
Set Appshell = CreateObject("Shell.Application")
Set Browsedir = Appshell.BrowseForFolder(0, "Select a Folder", &H1000, "E:\Xample\Path")
' check if not cancalled
If Not Browsedir Is Nothing Then
Folderpath = Browsedir.items().Item().Path
Else
GoTo Quit
End If
KeyWord = "The_Materialist_Example"
' go through all files in the folder
For Each f In FSO.GetFolder(Folderpath).Files
' if file is a pdf , open, check for keyword, decide if should be printed
If LCase(Right(f.Name, 3)) = "pdf" Then
' Here the methods suggest different answers.
' You can either use FollowHyperLink or use the Adobe Library to OPEN PDF
' I would write a function that checks the active pdf for the keyword : IsKeyFound
Debug.Print Folderpath & "\" & f.Name
Call PrintPDF(Folderpath & "\" & f.Name)
If IsKeyFound(f, KeyWord) Then
f.Print
End If
End If
Next f
Quit:
End Sub
Private Sub PrintPDF(strPDFFileName As String)
Dim sAdobeReader As String 'This is the full path to the Adobe Reader or Acrobat application on your computer
Dim RetVal As Variant
sAdobeReader = "C:\Program Files (x86)\Adobe\Acrobat Reader DC\Reader\AcroRd32.exe"
'Debug.Print sAdobeReader & "/P" & Chr(34) & strPDFFileName & Chr(34)
RetVal = Shell(sAdobeReader & " /P " & Chr(34) & strPDFFileName & Chr(34), 0)
End Sub
Private Function IsKeyFound(PDF As Variant, KeyWord As String) As Boolean
'Decide if file needs to be printed, insert your criteria and search algorithm here
End Function
I have not been able to figure out how to extract the keywords, you could however use a user input as a first approach and later move on to a automated scan of the pdf.
I hope this gets you further on the way to the solution.
I am currently trying to put a macro together to sort files into folders based on a filename. I am locked into using VBA due to the system we are on.
For example sorting just the excel documents from below present in C:\ :
123DE.xls
124DE.xls
125DE.xls
124.doc
123.csv
into the following folder paths:
C:\Data\123\Data Extract
C:\Data\124\Data Extract
C:\Data\125\Data Extract
The folders are already created, and as in the example are named after the first x characters of the file. Batches of 5000+ files will need to be sorted into over 5000 folders so im trying to avoid coding for each filename
I am pretty new to VBA, so any guidance would be much appreciated. So far I have managed to move all the excel files into a single folder, but am unsure how to progress.
Sub MoveFile()
Dim strFolderA As String
Dim strFolderB As String
Dim strFile as String
strFolderA = "\\vs2-alpfc\omgusers7\58129\G Test\"
strFolderb = "\\vs2-alpfc\omgusers7\58129\G Test\1a\"
strFile = Dir(strFolderA & "*.xlsx*")
Do While Len(strFile) >0
Name StrFolderA & strFile As strFolderB & strFile
strFile = Dir
Loop
End Sub
Greg
EDIT
Sub MoveFile()
Dim strFolderA As String
Dim strFile As String
Dim AccNo As String
strFolderA = "\\vs2-alpfc7\omgUSERS7\58129\G Test\"
strFile = Dir(strFolderA & "*.xlsx*")
Do While Len(strFile) > 0
AccNo = Left(strFile, 2)
Name strFolderA & strFile As strFolderA & "\" & AccNo & "\Data Extract\" & strFile
strFile = Dir
Loop
End Sub
Thanks folks, are a few more bits and pieces i want to add, but functionality is there!
Sub DivideFiles()
Const SourceDir = "C:\" 'where your files are
Const topdir = "\\vs2-alpfc\omgusers7\58129\G Test\"
Dim s As String
Dim x As String
s = Dir(SourceDir & "\*.xls?")
Do
x = Left(s, 3) 'I assume we're splitting by first three chars
Name SourceDir & s As topdir & s & "\" & s
Loop Until s = ""
End Sub
If I understand you correctly, the problem is deriving the new fullpathname from the file name to use as the newpathname argument of the Name function.
If all of your files end with DE.XLS* you can do something like:
NewPathName = C:\Data\ & Split(strFile, "DE")(0) & "\Data Extract\" & strFile
You could use Filesystem object (tools > references > microsoft scripting runtime
This does a copy first then delete. You can comment out delete line and check copy is safely performed.
If on Mac replace "\" with Application.PathSeparator.
Based on assumption, as you stated, that folders already exist.
Option Explicit
Sub FileAway()
Dim fileNames As Collection
Set fileNames = New Collection
With fileNames
.Add "123DE.xls"
.Add "124DE.xls"
.Add "125DE.xls"
.Add "124.doc"
.Add "123.csv"
End With
Dim fso As FileSystemObject 'tools > references > scripting runtime
Set fso = New FileSystemObject
Dim i As Long
Dim sourcePath As String
sourcePath = "C:\Users\User\Desktop" 'where files currently are
For i = 1 To fileNames.Count
If Not fso.FileExists("C:\Data\" & Left$(fileNames(i), 3) & "\Data Extract\" & fileNames(i)) Then
fso.CopyFile (sourcePath & "\" & fileNames(i)), _
"C:\Data\" & Left$(fileNames(i), 3) & "\Data Extract\", True
fso.DeleteFile (sourcePath & "\" & fileNames(i))
End If
Next i
End Sub
I am working on editing some code that was written by someone else and I have had very little Excel Macro experience. I am attempting to save a file to a network location after the code completes. The person who made this program had it being saved to the wrong location and didn't have it checking if the Folder exists or not.
This is what I currently have for grabbing the file for formatting...
It needs to grab the variable file name &MA&.txt from this location...
C:\Twist Check Vaules\&MS& &MP&\$MA%.txt
For example, if MS = TEST and MP = GO and MA = A then...
C:\Twist Check Vaules\TEST GO\A.txt
[Formats File]
Then at the end it needs to check to see if there is already a folder with the same name as the variables above but in a separate location...
Ex. Check for this folder...
O:\diaph\sdata\Blinglet\&MS& &MP&
For example, if MS = TEST and MP = GO...
O:\diaph\sdata\Blinglet\TEST GO
If this folder exists it needs to keep moving on, if not it needs to create it.
Then finally the file by the name of $MA$.txt or using the example, A.txt needs to be saved in that location...
O:\diaph\sdata\Blinglet\TEST GO
I tried looking this up myself but I have been having a lot of trouble since I am so new to excel macro. Any help would be much appreciated!
Sub Polywork_Formating_Macro()
MsgBox ("Polyworks Data Formatting: Autostart Macro in Excel")
Dim idx As Integer
Dim fpath As String
Dim fname As String
Dim MS As String
Dim FileTitle As String
Dim MP As String
Dim MA As String
Dim question As Variant
MS = InputBox("Enter Shop Order:", "File Name")
MP = InputBox("Enter Job Number:", "File Name")
MA = InputBox("Enter A, B , or 360:", "File Name")
FileTitle = " " & MA & ".xls"
idx = 0
fpath = "C:\Twist Check Values\" & MS & "\" & MP & "\" & MA & "\"
fname = Dir(fpath & "*.txt")
While (Len(fname) > 0)
idx = idx + 1
Sheets.Add.Name = fname`enter code here`
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" _
& fpath & fname, Destination:=Range("A2"))
.Name = "a" & idx
[
FORMATTING CODE IN THE MIDDLE REMOVED
]
ActiveWorkbook.SaveAs Filename:="O:\diaph\sdata\Blinglet\" & MS & "\" & MP & "\" & FileTitle & ""
question = MsgBox("Are There AnyMore Files To Be Formated?", vbYesNo)
If question = vbYes Then
Workbooks.Open "C:\Stage Formatter.xlsm"
End If
End Sub
For you file path and name you need double quotes around the strings.
Dim strFilePath as string
str = "C:\Twist Check Vaules\" & MS & MP & "\" & MA & ".txt
For you filesystem functions you will need to reference the library. In the VBA IDE go to the tools menu and select references. Select "Microsoft scripting runtime".
Then you can declare a filesystemobject. That can be used for you folder and file functions.
Dim fldr As Object
Dim strFolder as string
Dim fs As FileSystemObject
Set fs = New FileSystemObject
strFolder = "C:\Twist Check Vaules\" & MS & MP & "\"
If fs.FolderExists(strFolder) = true Then
'Do nothing
else
msbbox ("Folder is missing")
'or you can create it
Set fldr = fs.CreateFolder(strFolder)
If fldr Is Nothing Then
MsgBox "Could not create the folder"
End If
End if
For your text file:
Dim ts As TextStream
Set fs = New FileSystemObject
Set ts = fs.CreateTextFile("C:\Temp\test.txt", True, False)
ts.WriteLine "Whatever text you are writing to the file."
'Clean up
ts.Close: Set ts = Nothing
Set fs = Nothing
I am trying to open a file with a file name which changes every week. This means that the date part on the file name is varying. Also, this file is the ONLY file inside the folder. But its file name is changing. I am using the code below but it was throwing the error, 'Run time 52: Bad file name & number'. I need your help.
Dim ThePath As String
Dim TheFile As String
ThePath = "https://ts.company.com/sites/folder1/folder2/folder3/folder4/"
TheFile = Dir(ThePath & "MANILA_ShiftRecord_*" & ".xlsx")
Workbooks.Open (ThePath & TheFile)
Thanks!
If it's only one file you can use this approach:
Dim sharepointFolder As String
Dim colDisks As Variant
Dim objWMIService As Object
Dim objDisk As Variant
Dim driveLetter As String
'Create FSO and network object
Set objNet = CreateObject("WScript.Network")
Set fs = CreateObject("Scripting.FileSystemObject")
'Get all used Drive-Letters
Set objWMIService = GetObject("winmgmts:\\" & "." & "\root\cimv2")
Set colDisks = objWMIService.ExecQuery("Select * from Win32_LogicalDisk")
'Loop through used Drive-Letters
For Each objDisk In colDisks
For i = 65 To 90
'If letter is in use exit loop and remember letter.
If i = Asc(objDisk.DeviceID) Then
j = i
Exit For
'letters which are not checked yet are possible only
ElseIf i > j Then
driveLetter = Chr(i) & ":"
Exit For
End If
Next i
'If a Drive-Letter is found exit the loop
If driveLetter <> "" Then
Exit For
End If
Next
'define path to SharePoint
sharepointFolder = "https://spFolder/Sector Reports/"
'Map the sharePoint folder to the free Drive-Letter
objNet.MapNetworkDrive driveLetter, sharepointFolder
'set the folder to the mapped SharePoint-Path
Set folder = fs.GetFolder(driveLetter)
Afterwards you can handle the folder with filesystemobject functions.