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
Related
I copied this code from a differen website to try and help me import multiple text files at once. I changed filepaths, text specs, and the table to what I need. Now every time I try to run this is locks up and doesn't respond.
Is there an issue with having too many text files or too much data? How come its causing my program to lock up?
Public Sub WorkedAlertsImport()
On Error GoTo bImportFiles_Click_Err
Dim objFS As Object, objFolder As Object
Dim objFiles As Object, objF1 As Object
Dim strFolderPath As String
strFolderPath = "C:\Import TXT files\"
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFS.GetFolder(strFolderPath)
Set objFiles = objFolder.files
For Each objF1 In objFiles
If Right(objF1.Name, 3) = "txt" Then
DoCmd.TransferText acImportDelim, "TextImportSpecs", "tblImportedFiles", strFolderPath & objF1.Name, False
Name strFolderPath & objF1.Name As "C:\Import TXT files\" & objF1.Name 'Move the files to the archive folder
End If
Next
Set objF1 = Nothing
Set objFiles = Nothing
Set objFolder = Nothing
Set objFS = Nothing
bImportFiles_Click_Exit:
Exit Sub
bImportFiles_Click_Err:
MsgBox Err.Number & " " & Err.Description
Resume bImportFiles_Click_Exit
End Sub
After a cursory review of your code, I see no reason why it would cause MS Access to lock up, which would typically be caused by code executing a loop which never met a terminating condition (however, a For Each loop is iterating over a fixed set of data and will therefore always terminate).
I would note that the following line is redundant:
Name strFolderPath & objF1.Name As "C:\Import TXT files\" & objF1.Name
Since earlier in the code you define strFolderPath as:
strFolderPath = "C:\Import TXT files\"
Hence, you are renaming the file to itself.
The code is also naïvely testing the last three characters of the filename, which may not necessarily yield an extension if you were to encounter a file without an extension.
The code could be written without using the FSO and without the if statement altogether, as VBA offers the Dir function as standard to iterate over files of a particular type in a directory, e.g.:
Sub test()
Dim strDir As String: strDir = "C:\Import TXT files"
Dim strTxt As String: strTxt = Dir(strDir & "\*.txt")
Do Until strTxt = vbNullString
DoCmd.TransferText acImportDelim, "TextImportSpecs", "tblImportedFiles", strDir & "\" & strTxt, False
strTxt = Dir
Loop
End Sub
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 have an email message with an image attachment that I want to save with a VBA macro. The file name and the display name show French accents in the attachment name (e.g. "Événement.jpg").
Saving the attachment with Outlook VBA works:
Dim fso As Object
Dim sFileName As String
Dim oAttachment As Outlook.attachment
set fso = CreateObject("Scripting.FileSystemObject")
' Edit the folder location accordingly:
sFileName = "C:\Users\YOUR_ACCOUNT_HERE\Desktop\" & oAttachment.getFileName
oAttachment.SaveAsFile sFileName
I can see the file correctly named on the file system.
Trying to access this file within VBA later on fails. The following code always returns FALSE:
' Returns False
MsgBox "File [" & sFileName & "] exists? " & sfo.fileexists(sFileName), vbInformation
Dim bFileExists as Boolean
If lenB (Dir(sFileName) > 0 Then
bFileExists = True
Else
bFileExists = True
EndIf
' Also returns False
MsgBox "File [" & sFileName & "] exists? " & bFileExists, vbInformation
What am I doing wrong?
I eventually came upon a workaround, thanks to the MS-DOS "8.3" file naming legacy of Windows. Converting the file name to its short file name makes Dir() and Open() happy:
Dim sFileShortName As String
sFileShortName = fso.Getfile(sTempFileLocation).shortpath
bFileExists = (Dir(sFileShortName) <> "") ' Now returns True at last!
Now fso.FileExists(sFileShortName) as well as bFileExists (based on Dir()) return True and Open sFileShortName For Binary Access Read As lFileNum works as well.
I hope that this will be beneficial to others.
I am writing some code that prompts the user to add a folder name, then copies all the files on the CD drive (D:) to C:\Example\ & FolderName if it doesn't already exist.
The code works until I try to copy files to a folder that already exists then I get a Run-time error 70: Permission Denied. Any help would be greatly appreciated.
Public Sub CopyFiles()
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
Dim FNames As String
Dim FolderName As String
FolderName = InputBox(Prompt:="Your folder name", Title:="Folder Name", default:="Folder Name here")
If Dir("C:\Example\" & FolderName & "\", vbDirectory) = "" Then
MkDir "C:\Example\" & FolderName
Else
End If
FromPath = "D:\"
ToPath = "C:\Example\" & FolderName & "\"
FileExt = "*.flac*"
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If
FNames = Dir(FromPath & FileExt)
If Len(FNames) = 0 Then
MsgBox "No files in " & FromPath
Exit Sub
End If
Set FSO = CreateObject("scripting.filesystemobject")
FSO.CopyFile Source:=FromPath & FileExt, Destination:=ToPath
End Sub
The problem is not that the folder exists. The problem is that you are trying to copy files and overwrite them
Overwriting is usually not a problem but fails if the files in the destination folder have Read Only Attributes. You can read more about it in this MSDN Article
What happened was when you first copied the files from the CD Drive, the file which where copied retained the Read Only Property. You can check that by Right Clicking on the File and checking their properties.
To overcome this problem, you need to reset the file attributes or delete the files in that folder.
To delete, you can simply use
On Error Resume Next
Kill "C:\MyFolder\*.*"
On Error GoTo 0
To change the attributes, you have to loop through the file and check if their property is read only. You can do that by
If fso.GetFile(Dest_File).Attributes And 1 Then
and to reset it, you have to use
fso.GetFile(Dest_File).Attributes = fso.GetFile(Dest_File).Attributes - 1
Once you do that you will be able to copy the files across.
As Siddharth mentioned, the error occurs because the code is trying to overwrite existing files. So, if you don't want to overwrite the files, you can simply add a If Error Resume Next. The solution code I am using is below:
Public Sub CopyFiles()
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
Dim FNames As String
Dim FolderName As String
FolderName = InputBox(Prompt:="Your folder name", Title:="Folder Name", default:="Folder Name here")
If Dir("C:\Example\" & FolderName & "\", vbDirectory) = "" Then
MkDir "C:\Example\" & FolderName
Else
End If
FromPath = "D:\"
ToPath = "C:\Example\" & FolderName & "\"
FileExt = "*.flac*"
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If
FNames = Dir(FromPath & FileExt)
If Len(FNames) = 0 Then
MsgBox "No files in " & FromPath
Exit Sub
End If
Set FSO = CreateObject("scripting.filesystemobject")
On Error Resume Next
FSO.CopyFile Source:=FromPath & FileExt, Destination:=ToPath
On Error GoTo 0
End Sub