Option Explicit
'' ***************************************************************************
'' Purpose : List selected files from a directory
'' Written : 26-Feb-1999 by Andy Wiggins - Byg Software Ltd
''
' Two versions of this macro are shown here.
' The first version is the modified version which will parse the directories into separate columns
' The second version is the original version.
Sub ListFiles()
Dim vvRes ''Variant to collect result
Dim viLoopCounter% ''For loop counter
Dim CRCol As Integer
Dim i As Integer
Dim nWS As Worksheet
Application.ScreenUpdating = False
On Error GoTo Endit ' this is messy. The macro will add a sheet anyway and then delete it without asking. It works though.
Set nWS = Worksheets.Add
nWS.Cells.Activate
''Set an error trap - gets around a "Cancel" situation
''Clear the target range, column "A"
Cells.Columns(1).ClearContents
''Go to the top left cell
Cells(1, 1).Select
''Show the file open box and get a result
vvRes = Application.GetOpenFilename("The lot, *.*", MultiSelect:=True)
''Loop for each result in the "fileToOpen" result ..
For viLoopCounter = LBound(vvRes) To UBound(vvRes)
'' .. and input to a cell
Cells(viLoopCounter, 1) = vvRes(viLoopCounter)
Next
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, other:=True, OtherChar _
:="\", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
1)), TrailingMinusNumbers:=True
Cells.Select
Selection.Columns.AutoFit
Do While Range("A1").Value = ""
Columns(1).EntireColumn.Delete
Loop
Range("A1").Select
CRCol = Selection.CurrentRegion.Columns.Count
For i = 1 To CRCol - 2
Columns(1).EntireColumn.Delete
Next i
Range("A1").EntireRow.Insert
Range("A1").Select
With Selection
.Value = "Folder"
.Font.FontStyle = "Bold"
End With
Range("B1").Select
With Selection
.Value = "Filename"
.Font.FontStyle = "Bold"
End With
On Error Resume Next
nWS.Name = Range("A2").Value
GoTo Finish ' the macro has run with no errors
Endit: ' perhaps someone cancelled half-way, but a sheet has been added anyway. The section deletes that sheet.
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
Finish:
End Sub
Sub FileNametoExcel()
Dim fnam As Variant
' fnam is an array of files returned from GetOpenFileName
' note that fnam is of type boolean if no array is returned.
' That is, if the user clicks on cancel in the file open dialog box, fnam is set to FALSE
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
Range("A1").Select
ActiveCell.FormulaR1C1 = "Path and Filenames that had been selected to Rename"
Range("A1").Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
End With
Columns("A:A").EntireColumn.AutoFit
Range("B1").Select
ActiveCell.FormulaR1C1 = "Input New Filenames Below"
Range("B1").Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Bold"
.Size = 10
End With
Columns("B:B").EntireColumn.AutoFit
' 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
'if user hits cancel, then end
For b = 1 To UBound(fnam)
' print out the filename (with path) into first column of new sheet
ActiveSheet.Cells(b + 1, 1) = fnam(b)
Next
End Sub
Sub RenameFile()
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 Sub
