The following code goes through all PDF files in a folder, gets the first word of the file name and checks excel spreadsheet if the word it exists in a range.If it does not exist, it renames the file and adds the word "uploaded". The issue is that once it goes through all the files in the folder in goes through them again and again. How can I prevent this from happening?
Sub checkmissing()
Dim MyFolder As String, MyFile As String,
Dim ioid As String
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
MyFolder = .SelectedItems(1)
Err.clear
End With
MyFile = Dir(MyFolder & "\" & "*.pdf")
Do While MyFile <> ""
DoEvents
On Error GoTo 0
ioid = Split(MyFile, " ")(0)
Range("G1").Activate
With ActiveSheet.Range("G1:G10000")
Set c = .Find(ioid, LookIn:=xlValues)
If c Is Nothing Then
Name MyFolder & "\" & MyFile As MyFolder & "\" & "Uploaded " & MyFile
End If
End With
ChDir MyFolder
0
MyFile = Dir
Loop
End Sub
Related
I am attempting to rename files found in a main folder, but then put the renamed files in the same directory as the files to be copied. This is my original folder structure:
Main Folder
|
|____file1.txt
|____file2.txt
|____file1.txt
I want to now create a folder under the Main Folder called "Renamed" and place the renamed files in there. The new folder structure should look like this after successfully executing the code:
Main Folder
|
|____Renamed
| |
| |____renamed-file1.txt
| |____renamed-file2.txt
| |____renamed-file3.txt
|
|____file1.txt
|____file2.txt
|____file1.txt
However, in the code that I have so far, I cannot create the "Renamed" folder under the Main Folder as I get the error message Run-time error '5': Invalid procedure call or argument that seem to occur at the line fso.CopyFolder sItem, strPath2. Can you help me create the folder structure with the renamed folder and files.
Here is my code:
Sub RenameFile()
Dim fldr As FileDialog
Dim sItem As String
Dim strPath As String
Dim strPath1 As String
Dim strPath2 As String
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
Dim z As String
Dim s As String
Dim V As Integer
Dim TotalRow As Integer
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
TotalRow = ActiveSheet.UsedRange.Rows.Count
NextCode:
strPath = sItem
strPath2 = fso.BuildPath(sItem, "Renamed")
' Create the folder "Renamed"
fso.CopyFolder sItem, strPath2
For V = 1 To TotalRow
' Get value of each row in columns 1 start at row 2
z = Cells(V + 1, 1).Value
' Get value of each row in columns 2 start at row 2
s = Cells(V + 1, 2).Value
Dim sOldPathName As String
sOldPathName = fso.BuildPath(strPath2, z)
sNewPathName = fso.BuildPath(strPath2, s)
Name sOldPathName As sNewPathName
On Error Resume Next
Name sOldPathName As s
Next V
MsgBox "Congratulations! You have successfully renamed all the files"
End Sub
Copy and Rename Files Using Dir and FileCopy
Using FileCopy is much faster, simpler, and more straightforward: it copies and renames in one go.
This is a simplified example to get you familiar with Dir and FileCopy. In your case, you would 'Dir' each name in column A and if the length of the filename is greater than 0 (confirming that the file exists), you would 'FileCopy the source path to the destination path (using the names in column B)'.
Sub RenameFiles()
' Source
Const sFilePattern As String = "*.*"
Dim sInitPath As String: sInitPath = Application.DefaultFilePath & "\"
' Destination
Const dSubFolderName As String = "Renamed"
Const dPrefix As String = "renamed-"
Dim sFolderPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select a Folder"
.InitialFileName = sInitPath
If .Show <> -1 Then
MsgBox "You canceled.", vbExclamation
Exit Sub
End If
sFolderPath = .SelectedItems(1) & "\"
End With
Dim dFolderPath As String: dFolderPath = sFolderPath & dSubFolderName & "\"
If Len(Dir(dFolderPath, vbDirectory)) = 0 Then MkDir dFolderPath
Dim sFileName As String: sFileName = Dir(sFolderPath & sFilePattern)
If Len(sFileName) = 0 Then
MsgBox "No files found.", vbExclamation
Exit Sub
End If
On Error GoTo FileCopyError
Do Until Len(sFileName) = 0
FileCopy sFolderPath & sFileName, dFolderPath & dPrefix & sFileName
sFileName = Dir
Loop
On Error GoTo 0
MsgBox "Congratulations! You have successfully renamed all the files.", _
vbInformation
Exit Sub
FileCopyError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description _
& vbLf & "Could not copy '" & sFileName & "'."
Resume Next
End Sub
I'm trying to activate the browse file. However, when the file name has a "[]" it has an error "Subscript out of range". I would like to recognize the "[]" to activate the file. I will copy the whole data on the file, that's why I will activate it. But, when I'm trying to manually remove the "[]" in the file name, it works successfully. Thanks for the help !
Here is my code:
Sub Test()
Dim fldr As FileDialog
Dim sItem As String
Dim shtName As String
'select folder
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
'Get the path
GetFolder = sItem
Set fldr = Nothing
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Check if exist the word in file name
wrd = "AS"
'get the file associated with wrd
strfile = Dir(GetFolder & "\*" & wrd & "*.xl*")
fc = 0
Do While Len(strfile) > 0
On Error GoTo endhere
fc = fc + 1
'open the file
Workbooks.Open (GetFolder & "\" & strfile)
Workbooks(strfile).Activate
here:
Workbooks(strfile).Close False
strfile = Dir
Loop
endhere:
Debug.Print Err.Description
End Sub
Try
Dim strFile1 as String
If InStr(strfile, "[") > 0 Then
strFile1 = Replace(Replace(strfile, "[", ""), "]", "")
Name GetFolder & "\" & strfile As GetFolder & "\" & strFile1
Workbooks.Open (GetFolder & "\" & strFile1)
Else
Workbooks.Open (GetFolder & "\" & strfile)
End If
If the characters to be removed do not belong to the file name, belonging to the path, please use the next way:
Dim strFile1 As String
If InStr(GetFolder & "\" & strfile, "[") > 0 Then
strFile1 = Replace(Replace(GetFolder & "\" & strfile, "[", ""), "]", "")
Name GetFolder & "\" & strfile As strFile1
Workbooks.Open (strFile1)
Else
Workbooks.Open (GetFolder & "\" & strfile)
End If
Anyhow, this second version can be use for both cases...
Not sure if this is Excel-Version dependent, for me it gives no error. I can open the file and access it with the name that the Dir returned, even if the Name-property of the workbook replaces the the square brackets with round one (interesting, didn't know that).
However, much more important is that you neither need to Activate the workbook nor use the name to open and close it. Workbooks.Open is a Function that returns a reference to the opened Workbook, so you should use that:
Dim wb As Workbook
Set wb = Workbooks.Open (GetFolder & "\" & strfile)
' (...) do your stuff using wb, eg copy a Worksheet:
wb.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
wb.Close False
I am trying to loop through all the 'xlsx' files in a folder and convert them to 'xls' ( Excel 97-2003 Worksheet) format. I use the following codes but then the output files are still saved as 'xlsx' instead of 'xls'. I am a beginner and looking to learn more from others. Thanks for your help!
Sub Convert()
Dim strPath As String
Dim strFile As String
Dim strfilenew As String
Dim xWbk As Workbook
Dim xSFD, xRFD As FileDialog
Dim xSPath As String
Dim xRPath As String
Set xSFD = Application.FileDialog(msoFileDialogFolderPicker)
With xSFD
.Title = "Please select the folder contains the xls files:"
.InitialFileName = "C:\"
End With
If xSFD.Show <> -1 Then Exit Sub
xSPath = xSFD.SelectedItems.Item(1)
Set xRFD = Application.FileDialog(msoFileDialogFolderPicker)
With xRFD
.Title = "Please select a folder for outputting the new files:"
.InitialFileName = "C:\"
End With
If xRFD.Show <> -1 Then Exit Sub
xRPath = xRFD.SelectedItems.Item(1) & "\"
strPath = xSPath & "\"
strFile = Dir(strPath & "*.xlsx")
strfilenew = Dir(strPath & "*.xls")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Do While strFile <> ""
If Right(strFile, 4) = "xlsx" Then
Set xWbk = Workbooks.Open(Filename:=strPath & strfilenew)
xWbk.SaveAs Filename:=xRPath & strfilenew, _
FileFormat:=xlExcel18
xWbk.Close SaveChanges:=True
End If
strFile = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
There was a bit of a mix-up in your file naming, basically as evidenced by the several double-declarations that I removed. The really big mistake was here, Set xWbk = Workbooks.Open(Filename:=strPath & strfilenew) where you tried to open the old workbook by the new name. I think the confusion started here "Please select the folder contains the xls files:". Of course, this is the folder with the XLSX files. The recommended antidote is to use "meaningful" variable names but you chose to speak in riddles (like xSFD) which makes coding more difficult.
However, the code below is largely yours, and it does work.
Sub Convert()
' 230
Dim Spath As String ' path to read from (XLSX files)
Dim Rpath As String ' path to write to (XLS files)
Dim strFile As String ' loop variable: current file name
Dim Wbk As Workbook ' loop object: current workbook(strFile)
Dim Sp() As String ' split array of strFile
Dim strFileNew As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select the folder contains the XLSX files:"
.InitialFileName = "C:\"
If .Show <> -1 Then Exit Sub
Spath = .SelectedItems.Item(1) & "\"
End With
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder for outputting the new files:"
.InitialFileName = "C:\"
If .Show <> -1 Then Exit Sub
Rpath = .SelectedItems.Item(1) & "\"
End With
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
strFile = Dir(Spath & "*.xlsx")
Do While strFile <> ""
If Right(strFile, 4) = "xlsx" Then
Sp = Split(strFile, ".")
Sp(UBound(Sp)) = "xls"
strFileNew = Join(Sp, ".")
Set Wbk = Workbooks.Open(Filename:=Spath & strFile)
Wbk.SaveAs Filename:=Rpath & strFileNew, FileFormat:=xlExcel8
Wbk.Close SaveChanges:=True
End If
strFile = Dir
Loop
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Observe that the new file name is created by splitting the old name on periods, changing the last element, and reassembling the modified array.
I am having 2 issues with the below code.
on the first loop it finds the same file, hence why I have it skip if the file is the same name. After that it will proceed as it should. On the 3rd loop instead of finding the 3rd file (fileName2 = Dir) becomes fileName2 = "".
When I want fileName to go to the second file (fileName = Dir) I get a run time 5 error.
*Note: I currently have 6 files in the folder that I am testing but I will want to use for folders that have 10,000 small files
Sub TestMD5()
Dim myfilepath As String
Dim myfilepath2 As String
Dim fileName As Variant
Dim fileName2 As Variant
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem & "\"
Set fldr = Nothing
fileName = Dir(GetFolder)
fileName2 = Dir(GetFolder)
Do While fileName <> ""
Do While fileName2 <> ""
myfilepath = GetFolder & fileName
myfilepath2 = GetFolder & fileName2
If myfilepath <> myfilepath2 Then
If FileToMD5Hex(myfilepath) = FileToMD5Hex2(myfilepath2) And FileToSHA1Hex(myfilepath) =
FileToSHA1Hex2(myfilepath2) Then
'Kill (myfilepath2)
Debug.Print "match - " & (fileName) & " & " & (fileName2)
Else
Debug.Print "no match - " & (fileName) & " & " & (fileName2)
End If
End If
fileName2 = Dir
Loop
'Set the fileName to the next file
fileName = Dir
Loop
End Sub
I mashed your code together with the "File system Object" approach, where we can do a For each loop on the files.
This at least gets you away from the whole run time 5 error. Maybe it could be of use.
Sub TestMD5()
Dim myfilepath As Variant, myfilepath2 As Variant
Dim sItem As String
Dim fso As Object
Dim fldr As Variant
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
Set fso = CreateObject("Scripting.FileSystemObject")
Set fldr = fso.GetFolder(sItem & "\")
For Each myfilepath In fldr.Files
For Each myfilepath2 In fldr.Files
If Not myfilepath = myfilepath2 Then
If FileToMD5Hex(myfilepath) = FileToMD5Hex2(myfilepath2) And FileToSHA1Hex(myfilepath) = FileToSHA1Hex2(myfilepath2) Then
'Kill (myfilepath2)
Debug.Print "match - " & (myfilepath) & " & " & (myfilepath2)
Else
Debug.Print "no match - " & (myfilepath) & " & " & (myfilepath2)
End If
End If
Next myfilepath2
Next myfilepath
End Sub
I think FileDialog(msoFileDialogFilePicker) should be used instead of FileDialog(msoFileDialogFolderPicker)
I'm working on a code that will do the following:
1. Create folder based on the filename of the excel file in the same root folder
2. Move the excel file to the newly created folder with the same name
I'm having a problem in setting up the code that will check the excel files in the folder as it contains other excel files that I want to skip. The difference between the filenames is that the one I want to exclude are the filenames with a date at the start of the file name.
Here's what I have so far
Sub Create_Folder()
Dim ParentFolder As String
ParentFolder = ThisWorkbook.Path
myFile = Dir(ParentFolder)
Do While myFile <> "Australia Formatting" 'Or "20*"
Debug.Print myFile
Debug.Print Left(myFile, InStr(1, myFile, "_") - 1)
MkDir (ParentFolder & Left(myFile, InStr(1, myFile, "_") - 1))
Name ParentFolder & myFile As ParentFolder & Left(myFile, InStr(1, myFile, "_") - 1) & "\" & myFile
myFile = Dir
Loop
End Sub
Sub Create_Folder()
Dim ParentFolder As String
dim s as string
ParentFolder = ThisWorkbook.Path & "\"
myFile = Dir(ParentFolder & "*.xl??") 'only want to look at excel files
Do While myFile <> "" 'keep looking until all files have been checked
if myfile ="Australia Formatting" Or isdate(left(myfile,8)) then
'skip
else
s=Left(myFile, InStr(1, myFile, "_") - 1)
MkDir (ParentFolder & s)
Name ParentFolder & myFile As ParentFolder & s & "\" & myFile
end if
myFile = Dir()
Loop
End Sub
'done on my phone so i can't test this - may be typos