I'm renaming files in VBA using the following code
Sub Dateien_umbenennen()
Dim xDir As String
Dim xFile As String
Dim xRow As Long
Dim oFSO As Object
Set oFSO = CreateObject("Scripting.FileSystemObject")
xDir = oFSO.GetFolder(ThisWorkbook.Sheets("Sheet1").Range("F4").Value)
xFile = Dir(xDir & "\" & "*")
Do Until xFile = ""
xRow = 0
On Error Resume Next
xRow = Application.Match(xFile, Range("A:A"), 0)
If xRow > 0 Then
Name xDir & Application.PathSeparator & xFile As _
xDir & Application.PathSeparator & Cells(xRow, "B").Value
End If
xFile = Dir
Loop
End Sub
Old name in column A, new name in column B, folder specified by the value in cell F4. Some files in column A contain the ~ special character. Those files are not being renamed while the ones that don't have the character are. How can I rename the files that contain the ~ ?
I think that issue in xRow = Application.Match(xFile, Range("A:A"), 0). If you locate the row with, for example, name~1.txt, its need next syntax: xRow = Application.Match("name~~1.txt", Range("A:A"), e.g. double ~. Try this code: xRow = Application.Match(Replace(xFile,"~","~~"), Range("A:A"),0)
Related
I have an issue with the below code. It seems to work fine but apparently it is not able to move to the next file in the directory given; it gets in fact stuck to the first file, and it reopens it, without being able to move on to the next one. Any help super appreciated!
Sub Cash_Line_Check(strTargetPath)
Dim i As Long
Dim sPath As String
Dim sFil As String
Dim FolderPath As String
Dim diaFolder As FileDialog
Dim CurrReturnColumn As Range, TotReturnColumn As Range, VarTotReturnColumn As Range, CashRow As Range
Dim oWbk As Workbook
'Open the file dialog
Set diaFolder = Application.FileDialog(msoFileDialogFolderPicker)
diaFolder.AllowMultiSelect = False
diaFolder.InitialFileName = strTargetPath
diaFolder.Show
FolderPath = diaFolder.SelectedItems(1)
'Without wanting to use the promp, use the below line:
'FolderPath = strTargetFolder
'Cycle through spreadsheets in selected folder
sPath = FolderPath & "\" 'location of files
sFil = Dir(sPath & "*.xls") 'change or add formats
Do While sFil <> "" 'will start LOOP until all files in folder sPath have been looped through
sFilTop20 = Dir(sPath & "TOP20" & "*.xls")
If (Len(sFilTop20) > 0) Then GoTo loopline
Set oWbk = Workbooks.Open(sPath & "\" & sFil) 'opens the file
i = 1 'Selects the sheet to be analysed'
'Perform Check and Record those funds adjusted
With oWbk.Worksheets(i)
Set CurrReturnColumn = .UsedRange.Find("Currency", , xlValues, xlWhole, xlByColumns)
Set TotReturnColumn = .UsedRange.Find("Portfolio", , xlValues, xlWhole, xlByColumns) 'Looks by columns
Set VarTotReturnColumn = .UsedRange.Find("Variation", , xlValues, xlWhole, xlByRows) 'Looks by rows
Set CashRow = .UsedRange.Find("[Cash]", , xlValues, xlWhole, xlByRows)
If .Cells(CashRow.Row, CurrReturnColumn.Column) > 0.1 Or .Cells(CashRow.Row, CurrReturnColumn.Column) < -0.1 Then
.Cells(CashRow.Row, CurrReturnColumn.Column).Value = "-"
End If
If .Cells(CashRow.Row, TotReturnColumn.Column) > 0.1 Or .Cells(CashRow.Row, CurrReturnColumn.Column) < -0.1 Then
.Cells(CashRow.Row, TotReturnColumn.Column).Value = "-"
End If
If .Cells(CashRow.Row, VarTotReturnColumn.Column) > 0.1 Or .Cells(CashRow.Row, CurrReturnColumn.Column) < -0.1 Then
.Cells(CashRow.Row, VarTotReturnColumn.Column).Value = "-"
End If
End With
oWbk.Close True
sFil = Dir(sPath)
loopline:
Loop
End Sub
Different approach to loop through files I use.
Please note you need to check Microsoft Scripting Runtime in Tools>References
Sub find_reports()
Dim fname As String
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder
strPath = ThisWorkbook.Path
fname = ThisWorkbook.Name
Set objFolder = objFSO.GetFolder(strPath)
'If the folder does not contain files, exit the sub
If objFolder.Files.Count = 0 Then
MsgBox "No files in Folder", vbExclamation
Exit Sub
End If
'Loop through each file in the folder
For Each objFile In objFolder.Files
Debug.Print "Folder:" & strPath, "Filename: " & fname
Next objFile
End Sub
Here is a basic way to loop through all Excel files within a given folder:
Sub LoopExcelFiles()
Const xlsPath = "x:\ExcelTests"
Dim fName As String
fName = Dir(xlsPath & "\*.xl*") 'Find the first file
Do While fName <> "" 'keep looping until file isn't found
'do "whatever you gotta do" with each file here:
Debug.Print "Folder:" & xlsPath, "Filename: " & fName
fName = Dir() 'Find the next file (same criteria)
Loop
End Sub
Here is more on the Dir function.
I have an excel file that has two columns, column A & Column B.
The column A is "Path and filenames that had been selected", which has path of each file name in a network directory:
\\xxx\yyyy\gggg\ooo.pdf
\\xxx\yyyy\gggg\ogh.pdf
\\xxx\yyyy\gggg\pjo.pdf
The column B has "new file names", which are supposed to replace old file names (ooo.pdf, ogh.pdf, pjo.pdf):
fff.pdf
fgh.pdf
hjk.pdf
I have a code that is supposed to rename the old file names with new file names, but somehow it is not working effectively. PLease let me know what is wrong with the below code :
Sub RenameFiles()
Dim xDir As String
Dim xFile As String
Dim xRow As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then
xDir = .SelectedItems(1)
xFile = Dir(xDir & Application.PathSeparator & "*")
Do Until xFile = ""
xRow = 0
On Error Resume Next
xRow = Application.Match(xFile, Range("A:A"), 0)
If xRow > 0 Then
Name xDir & Application.PathSeparator & xFile As _
xDir & Application.PathSeparator & Cells(xRow, "B").Value
End If
xFile = Dir
Loop
End If
End With
End Sub
Please let me know the VBA code that can replace the old file name with the new file name in the directory.
You could use FileSystemObject:
Sub Iterator()
'Tools -> References -> Microsoft Scripting Runtime
Dim fso As New FileSystemObject
Dim fl As File
Dim r As Long
For r = 1 To 3
Set fl = fso.GetFile(Cells(r, "A")) 'Path is taken from column "A"
fl.Name = Cells(r, "B") 'Rename with name taken from column B
Next
End Sub
I have a list of file in 2 columns A and B.
A column is the source the B
B column is the destination
The code below copy file from source to destination. But if the destination exists it give me errors. What is the condition so that if it find that it exists it will not do anyting ??
What is the wrong with the code ?
Sub FC_Copy()
Dim ClientsFolderDestination
Dim fso As New FileSystemObject
Dim rep_destination
Dim source
lastrow = ThisWorkbook.Worksheets("XClients").Cells(Application.Rows.Count, 1).End(xlUp).Row
For i = 5 To lastrow
source = ThisWorkbook.Worksheets("XClients").Cells(i, 1).Value
ClientsFolderDestination= ThisWorkbook.Worksheets("XClients").Cells(i, 2).Value
If fso.FileExists(source) Then
rep_destination = Left(ClientsFolderDestination, Len(ClientsFolderDestination) - Len(fso.GetFileName(ClientsFolderDestination)) - 1)
If Not fso.FolderExists(rep_destination) Then
sub_rep = Split(rep_destination, "\")
myrep = sub_rep(0)
If Not fso.FolderExists(myrep) Then
MkDir myrep
End If
For irep = 1 To UBound(sub_rep)
myrep = myrep & "\" & sub_rep(irep)
If Not fso.FolderExists(myrep) Then
MkDir myrep
End If
Next
End If
fso.CopyFile source, ClientsFolderDestination
End If
Next i
end sub
Try this.
This doesn't use Microsoft Scripting Runtime Library.
It uses one common function to check for existence of file and folder
It caters for destination paths like C:\Sample.xlsx
Code
Sub FC_Copy()
Dim ws As Worksheet
Dim source As String, Destination As String, sTemp As String
Dim lRow As Long, i As Long, j As Long
Dim MyAr As Variant
Set ws = ThisWorkbook.Sheets("XClients")
With ws
'~~> Find Last Row
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 5 To lRow
source = .Range("A" & i).Value
Destination = .Range("B" & i).Value
MyAr = Split(Destination, "\")
'~~> This check is required for destination paths like C:\Sample.xlsx
If UBound(MyAr) > 1 Then
sTemp = MyAr(0)
For j = 1 To UBound(MyAr)
sTemp = sTemp & "\" & MyAr(j)
If Not FileFolderExists(sTemp) = True Then MkDir sTemp
Next j
End If
If Not FileFolderExists(Destination) Then FileCopy source, Destination
Next i
End With
End Sub
Public Function FileFolderExists(strFullPath As String) As Boolean
On Error GoTo Whoa
If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
On Error GoTo 0
Whoa:
End Function
If Not fso.FileExists(ClientsFolderDestination) Then
fso.CopyFile source, ClientsFolderDestination
End If
or if you want to overwrite the destination file
fso.CopyFile source, ClientsFolderDestination, True
CopyFile Method
So here is 1 part of a 3 part macro that lets you browse to a folder and consolidate/transpose/retain header of a bunch of .csv files. The problem we have is where to inject some code so that routing and account numbers are formatted as text and retain their leading zeros. If the easiest solution is to just format the entire sheet as text, that would work for us...whatever it takes without having to go into specifics since this info wont always be in the same column.
Thanks in advance!
Option Explicit
'Set a public constant variable
Public Const DNL As String = vbNewLine & vbNewLine
Sub ImportData()
'Declare all variables
Dim wb As Workbook, ws As Worksheet
Dim wbX As Workbook, wsX As Worksheet
Dim i As Long, iRow As Long, iFileNum As Long, sMsg As String
Dim vFolder As Variant, sSubFolder As String, sFileName As String
Dim bOpen As Boolean
'Turn off some application-level events to improve code efficiency
Call TOGGLEEVENTS(False)
'Have the user choose the folder
vFolder = BrowseForFolder()
'Exit if nothing was chosen, variable will be False
If vFolder = False Then Exit Sub
'Check if this is what the user wants to do, confirm with a message box, exit if no
sMsg = "Are you sure you want to import data from this folder:"
sMsg = sMsg & DNL & vFolder
If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "ARE YOU SURE?") <> vbYes Then Exit Sub
'Set sub-folder as variable for save name at end of routine
sSubFolder = Right(vFolder, Len(vFolder) - InStrRev(vFolder, Application.PathSeparator))
'Set destination file with one worksheet
Set wb = Workbooks.Add(xlWBATWorksheet)
Set ws = wb.Sheets(1)
'This will be the row to start data on, to incriment in loop
iRow = 2
'Loop through files in folder
sFileName = Dir$(vFolder & "\")
Do Until sFileName = ""
'Check that the file pattern matches what you want, i.e. 12.16.00.xls
If sFileName Like "*.csv" Then '### set file extension here
'Check to see if the file is open
'If file is open, set as variable, if not, open and set as variable
If ISWBOPEN(sFileName) = True Then
Set wbX = Workbooks(sFileName)
bOpen = True
Else
Set wbX = Workbooks.Open(vFolder & "\" & sFileName)
bOpen = False
End If
'Set first sheet in target workbok as worksheet variable, from which to mine data
Set wsX = wbX.Sheets(1)
'Get last row from column A (range for copy/pasting)
i = wsX.Cells(wsX.Rows.Count, 1).End(xlUp).Row
'Check if a file has been added, if not add headers (frequency)
If iFileNum = 0 Then
ws.Range("B1", ws.Cells(1, i + 1)).Value = Application.Transpose(wsX.Range("A1:A" & i))
End If
'Add data
ws.Range("B" & iRow, ws.Cells(iRow, i + 1)).Value = Application.Transpose(wsX.Range("B1:B" & i))
'Add file name to column A
ws.Range("A" & iRow).Value = "'" & Left$(sFileName, Len(sFileName) - 4)
'Incriment variable values
iRow = iRow + 1
iFileNum = iFileNum + 1
'If file was closed to start with, clean up and close it
If bOpen = False Then wbX.Close SaveChanges:=False
End If
'Get next file name
sFileName = Dir$()
Loop
'Check if file name to save exists
If Dir$(vFolder & "\" & sSubFolder & ".xls", vbNormal) = "" Then
wb.SaveAs vFolder & "\" & sSubFolder & ".xls"
MsgBox "Complete!", vbOKOnly
Else
MsgBox "File already exists! File is NOT saved!", vbInformation, "COMPLETE!"
End If
'Reset events back to application defaults
Call TOGGLEEVENTS(True)
End Sub
I'm trying to write a VBA macro that changes file names from the text in Column B to the text of Column A. For example, if I had:
Column A: Stack Overflow
Column B: Question
It would change Question.txt to Stack Overflow.txt. As of now I've slightly modified the code from the answer here to read:
Sub rename()
Dim Source As Range
Dim OldFile As String
Dim NewFile As String
Set Source = Cells(1, 1).CurrentRegion
For Row = 2 To Source.Rows.Count
OldFile = ActiveSheet.Range("D1").Value & ("\") & ActiveSheet.Cells(Row, 1) & (".pdf")
NewFile = ActiveSheet.Range("D1").Value & ("\") & ActiveSheet.Cells(Row, 2) & (".pdf")
' rename files
Name OldFile As NewFile
Next
End Sub
This works great, but I'm trying to get it to only run on selected rows; my ideal end result is that I can select the 15 non-consecutive rows that I want to change, run the macro, and have it only apply to those 15. I tried the below code but the ActiveSheet.Cells(Row, 1) function is returning a Run-Time Error 1004, Application-defined or object-definied error; is there a good way around this?
Sub renameMain()
Dim OldFile As String
Dim NewFile As String
Dim rng As Range
Set rng = Selection
For Each Row In rng
OldFile = ActiveSheet.Range("O1").Value & "\" & ActiveSheet.Range(Row, 2) & ".pdf"
NewFile = ActiveSheet.Range("O1").Value & "\" & ActiveSheet.Range(Row, 1) & ".pdf"
' rename files
Name OldFile As NewFile
Next Row
End Sub
Any advice would be much appreciated!
Non contiguous rows in the Selection object can be accessed using its .Areas collection:
Option Explicit
Sub renameMain()
Dim oldFile As String, newFile As String
Dim selArea As Range, selRow As Range, staticVal As String
With ActiveSheet
staticVal = .Range("O1").Value2 & "\"
For Each selArea In Selection.Areas
For Each selRow In selArea.Rows
oldFile = staticVal & .Cells(selRow.Row, 2).Value2
newFile = staticVal & .Cells(selRow.Row, 1).Value2
Name oldFile & ".pdf" As newFile & ".pdf" 'rename files
Next
Next
End With
End Sub
You seem to want to use Row as an int variable. It isn't. Maybe try this:
Sub renameMain()
Dim OldFile As String
Dim NewFile As String
Dim rng As Range
Dim i as long
Set rng = Selection
For i = 1 To rng.Rows.Count
OldFile = ActiveSheet.Range("O1").Value & "\" & rng.Cells(i, 2) & ".pdf"
NewFile = ActiveSheet.Range("O1").Value & "\" & rng.Cells(i, 1) & ".pdf"
' rename files
Name OldFile As NewFile
Next i
End Sub