I'm trying to create a list of file names in folder for reference, The following code is listing all the file names with extension Filename.pdf
how do I exclude the extension from file name? .pdf
Option Explicit
Sub GetFileName()
Dim xlRow As Long
Dim sDir As String
Dim FileName As String
Dim sFolder As String
sFolder = "C:\Temp\"
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder"
.InitialFileName = sFolder
.Show
If .SelectedItems.Count <> 0 Then
sDir = .SelectedItems(1) & "\"
FileName = Dir(sDir, 7)
Do While FileName <> ""
Range("A1").Offset(xlRow) = FileName
xlRow = xlRow + 1
FileName = Dir
Loop
End If
End With
End Sub
I'm not 100% sure what you are asking, but I think that
If FileName Like "*.pdf" Then
Range("A1").Offset(xlRow) = Mid(FileName,1,Len(FileName)-4)
End If
might be what you are after.
If the filename itself does not contain a period, you can use Split():
Option Explicit
Sub GetFileName()
Dim xlRow As Long
Dim sDir As String
Dim FileName As String
Dim sFolder As String
sFolder = "C:\Temp\"
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Please select a folder"
.InitialFileName = sFolder
.Show
If .SelectedItems.Count <> 0 Then
sDir = .SelectedItems(1) & "\"
FileName = Dir(sDir, 7)
Do While FileName <> ""
Range("A1").Offset(xlRow) = Split(FileName, ".")(0)
xlRow = xlRow + 1
FileName = Dir
Loop
End If
End With
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 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)
my code keeps getting a bad file name or number error and I can't figure out what the issue is, any help would be appreciated! I'm trying to store the filepath based on user selection as a variable which I can reference later in a vlookup. Below is my code, I can't figure out what's wrong but I used the pasted code in another macro which compiled fine.
sub edits
dim xpath and xfile as string
xPath = NewPath 'Newpath function executes
xfile = Dir$(xPath & "*.xlsm*", vbNormal) 'error here
Set SourceBook = Workbooks.Open(xPath & xfile)
End Sub
Function NewPath() As String
With Application.FileDialog(msoFileDialogOpen)
.ButtonName = "Choose a file"
.Title = "Previous File"
.AllowMultiSelect = False
If .Show Then xPath = .SelectedItems(1) & "\"
End With
End Function
Below is the code I've used which has compiled, it has the user select a folder instead of a file
sub something
dim xpath and xfile as string
xPath = NewPath
If Not strPath = vbNullString Then
xfile = Dir$(xPath & "*.xlsm", vbNormal)
Do While Not xfile = vbNullString
'some code
Set SourceBook = Workbooks.Open(xPath & xfile)
SourceBook.Close False
xfile = Dir$()
Loop
End If
End Sub
Function NewPath() As String
With Application.FileDialog(msoFileDialogFolderPicker)
.ButtonName = "Choose a folder"
.Title = "Folder Picker"
.AllowMultiSelect = False
If .Show Then NewPath = .SelectedItems(1) & "\"
End With
End Function
How do I programmatically change the file name of a .txt using excel vba, I need a script where it will go through a folder which consists of txt files and remove time from its filename.
Original Filename: ABC_ABCDE_ABCD_YYYYMMDDTTTTTT.txt
New Filename: ABC_ABCDE_ABCD_YYYYMMDD.txt
Thank you in advance
Mike
As per My understanding of your question, I write a code which asks a user to select the folder and rename ".txt" file as per requirements, you may be add an additional code of line for perfect work
'call sub LoopThroughFiles
'this sub is loop every file and rename it
Sub LoopThroughFiles()
Dim txtfile As String, folderPath As String
Dim newName As String
folderPath = GetFolder()
txtfile = Dir(folderPath & "\" & "*.txt")
While txtfile <> ""
If checkFormat(txtfile) = True Then
newName = Left(txtfile, 23) & ".txt"
On Error Resume Next
'rename file is done here
If Not txtfile = "" Then Name (folderPath + "\" + txtfile) As (folderPath + "\" + newName)
On Error GoTo 0
End If
txtfile = Dir
Wend
End Sub
'this function is for check format of file
'you may edit it as per your requirment
Function checkFormat(str As String) As Boolean
checkFormat = False
If Len(str) = 33 And Mid(str, 4, 1) = "_" Then
checkFormat = True
End If
End Function
'this function for select folder path
Function GetFolder() As String
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
End Function
Before use this code please make an additional copy of your file in case some error you have a backup...
Hope This help