| Input | Output | |||||||||||||
| (Auto Generated) | ||||||||||||||
| Item Nmae | Main Img | _1 | _2 | _3 | _4 | _5 | _6 | _7 | Main Image 1 | Img 2 | Img 3 | Img 4 | Img 5 | |
| Input | Output | |
| DSC_0133 | ren DSC_0133.JPG SP002.JPG | |
| DSC_0138 | ren DSC_0138.JPG SP003.JPG | |
| DSC_0139 | ren DSC_0139.JPG SP004.JPG | |
| DSC_0150 | ren DSC_0150.JPG SP007.JPG | |
| DSC_0151 | ren DSC_0151.JPG SP008.JPG | |
| DSC_0152 | ren DSC_0152.JPG SP009.JPG | |
| DSC_0153 | ren DSC_0153.JPG SP010.JPG |
I'm not quite sure what you are trying to do but to get rid of the spaces, sort the data. You can do it manually or you can have the code do it before you run your renaming routine. I was lazy and just recorded a quick sort as shown below:Hi There,As per your directions, I have managed to pull the above data into just 2 columns. 1 being Input and other being output in a new Tab of the same excel.However it contains empty cells in between.Actual Example:WHat should be the code to execute the file renaming where it asks for root folder and renames images as per input say starts from B4 till B500 and output as C4 till C500. given there are many blank spaces in between.I believe both columns need to contain the file extension as well.. right??Would be really helpful if you can suggest something on it.Eagerly waiting for a reply...
Input Output DSC_0133 ren DSC_0133.JPG SP002.JPG DSC_0138 ren DSC_0138.JPG SP003.JPG DSC_0139 ren DSC_0139.JPG SP004.JPG DSC_0150 ren DSC_0150.JPG SP007.JPG DSC_0151 ren DSC_0151.JPG SP008.JPG DSC_0152 ren DSC_0152.JPG SP009.JPG DSC_0153 ren DSC_0153.JPG SP010.JPG
<tbody>
</tbody>
Sub RenameFiles_Part1()
' List the file names
' after the files have been listed modify the file names
' And then run Part 2 which lists the full path of the files to be renamed
' copy the modified file names to column B of the worksheet "temp_RenameFiles"
' And then run part 3, which will rename the files
Application.DisplayAlerts = False
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets("temp_FileList")
If Not ws Is Nothing Then
ws.Delete
End If
On Error GoTo 0
Set ws = Worksheets.Add(Before:=ActiveSheet)
ws.Name = "temp_FileList"
ws.Activate
Application.DisplayAlerts = False
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Dim FileChosen As Integer, i As Long
Dim MyFile As Variant
i = 1
fd.AllowMultiSelect = True
fd.Show
For Each MyFile In fd.SelectedItems
ws.Cells(i, 1).Value = StrReverse(Mid(StrReverse(MyFile), 1, InStr(StrReverse(MyFile), "\") - 1))
i = i + 1
Next MyFile
End SubSub RenameFiles_Part2()
' List the full path of the files to be renamed
Application.DisplayAlerts = False
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets("temp_RenameFiles")
If Not ws Is Nothing Then
ws.Delete
End If
On Error GoTo 0
Set ws = Worksheets.Add(Before:=ActiveSheet)
ws.Name = "temp_RenameFiles"
ws.Activate
Application.DisplayAlerts = True
Dim fnam As Variant
Dim b As Integer 'counter for filname array
Dim b1 As Integer 'counter for finding \ in filename
Dim c As Integer 'extention marker
' format header
With ws
.Range("A1").Value = "Path and Filenames that had been selected to Rename"
.Range("B1").Value = "Input New Filenames Below"
End With
With ws.Range("A1:B1")
.Font.Name = "Arial"
.Font.FontStyle = "Bold"
.Font.Size = 10
End With
' first open a blank sheet and go to top left ActiveWorkbook.Worksheets.Add
fnam = Application.GetOpenFilename("all files (*.*), *.*", 1, _
"Select Files to Fill Range", "Get Data", True)
If TypeName(fnam) = "Boolean" And Not (IsArray(fnam)) Then Exit Sub
For b = 1 To UBound(fnam)
' print out the filename (with path) into first column of new sheet
ws.Cells(b + 1, 1) = fnam(b)
Next
ws.Range("A:B").EntireColumn.AutoFit
End SubSub RenameFiles_Part3()
' Rename the Files
Dim z As String
Dim S As String
Dim v As Integer
Dim TotalRow As Integer
TotalRow = ActiveSheet.UsedRange.Rows.Count
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 = z
On Error Resume Next
Name sOldPathName As S
Next v
MsgBox "Congratulations! You have successfully renamed all the files"
End SubSub GetFileList() Dim folderPath As String, nextFile As String, i As Long
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then
Range("A:C").ClearContents
Range("A1") = "Path:"
folderPath = .SelectedItems(1)
Range("B1") = folderPath
nextFile = Dir(folderPath & "\*.*")
i = 3
Do While nextFile <> ""
Cells(i, "A") = nextFile
i = i + 1
nextFile = Dir
Loop
Columns(1).EntireColumn.AutoFit
Else
MsgBox "No folder selected"
End If
End With
End Sub
Sub ChangeFileName()
Dim folderPath As String, nextFile As String, i As Long, lr As Long
Dim oldName As String, newName As String
folderPath = Range("B1").Value
lr = Cells(Rows.Count, "A").End(xlUp).Row
For i = 3 To lr
oldName = Cells(i, "A")
newName = Cells(i, "B")
If newName <> "" Then
oldName = folderPath & "\" & oldName
newName = folderPath & "\" & checkSuffix(oldName, newName)
If Not fileExists(newName) Then
Name oldName As newName
Cells(i, "C") = "Complete"
Else
Cells(i, "C") = "Failed"
End If
End If
Next i
Shell "Explorer " & folderPath, vbNormalFocus
End Sub
Function fileExists(ByVal str As String) As Boolean
fileExists = (Dir(str) <> "")
End Function
Function checkSuffix(ByVal o As String, n As String)
Dim f, s
f = Split(o, ".")
s = f(UBound(f))
If Right(n, Len(s)) = s Then
checkSuffix = n
Else
checkSuffix = n & "." & s
End If
End Function
