Bạn tham khảo thử link dưới rồi áp dụng cho trường hợp của bạn xem sao:
www.giaiphapexcel.com
A2:A... tên folde gốc
Sub ReName_Folder()
Dim fso As Object, sArr(), Res()
Dim i&, k&, n&, sRow&, oldFolder$, newFolder$
On Error Resume Next
Set fso = CreateObject("Scripting.FileSystemObject")
i = Range("A" & Rows.Count).End(xlUp).Row
sArr = Range("A2:A" & i).Value 'Folder nguon
Res = Range("B2:B" & i).Value 'Folder dich
sRow = UBound(sArr)
Do
For i = 1 To sRow
oldFolder = sArr(i, 1)
If oldFolder <> Empty Then
newFolder = Res(i, 1)
If fso.FolderExists(newFolder) Then
For n = 1 To 1000
If fso.FolderExists(newFolder & n) = False Then
Name oldFolder As newFolder & n
sArr(i, 1) = newFolder & n
Exit For
End If
Next n
Else
Name oldFolder As newFolder
sArr(i, 1) = Empty
k = k + 1
End If
End If
Next i
Loop Until k = sRow
End SubKhông biết Name oldFolder As newFolder có làm việc được với tên folder unicode không bạn?
Code không chạy được với tên folder tiếng Việt, và chưa bẩy hết lỗi
Sub ReName_Folder()
Dim FSo As Object, sArr(), Res()
Dim j&, i&, k&, n&, sRow&, oldFolder$, newFolder$
On Error Resume Next
Set FSo = CreateObject("Scripting.FileSystemObject")
i = Range("A" & Rows.Count).End(xlUp).Row
sArr = Range("A2:A" & i).Value 'Folder nguon
Res = Range("B2:B" & i).Value 'Folder dich
sRow = UBound(sArr)
For j = 1 To 3
For i = 1 To sRow
oldFolder = sArr(i, 1)
If oldFolder <> Empty Then
newFolder = Res(i, 1)
If FSo.FolderExists(newFolder) Then
For n = 1 To 1000
If FSo.FolderExists(newFolder & n) = False Then
FSo.MoveFolder oldFolder, newFolder & n
sArr(i, 1) = newFolder & n
Exit For
End If
Next n
Else
FSo.MoveFolder oldFolder, newFolder
sArr(i, 1) = Empty
k = k + 1
If k = sRow Then Exit Sub
End If
End If
Next i
Next j
End Sub
Tôi muốn đổi a->b, b1->c nhưng hiện tại chỉ có a và b. Đúng lý ra phải thông báo b đã tồn tại và không có b1 hoặc ít ra phải có thông báo lỗi. Nhưng code không báo gì hết, sau khi chạy code a->c, b giữ nguyên.
Sub RenameFolders()
Const Z = "tocsndfsshdwsdncshsskfsef"
Const MaxLenName As Integer = 260
Const Path = "C:\test\"
''------------------------------------
Dim FSO As Object, LR&, i&, j&, TempPath As String, Status As String
Dim DA As Object, DB As Object
Dim R As Excel.Range
''------------------------------------
Set DA = VBA.CreateObject("Scripting.Dictionary")
Set DB = VBA.CreateObject("Scripting.Dictionary")
Set FSO = VBA.CreateObject("Scripting.FileSystemObject")
''------------------------------------
Set R = Range("A2")
LR = R(Rows.Count - R.Row, 1).End(xlUp).Row - R.Row + 1
If LR <= 0 Then Exit Sub
''------------------------------------
' For i = 1 To LR
' If R(i, 2).Value Like "*:\*" Then
' Select Case True
' Case Len(Split(R(i, 1).Value, "\")(UBound(Split(R(i, 1).Value, "\")))) > MaxLenName
' Status = "Length Name Folder too long!!!"
' Case Else:
' DA(R(i, 1).Value) = R(i, 2).Value
' DB(R(i, 2).Value) = R(i, 1).Value
' End Select
' Else
' Status = "Name Folder not vailed!!!"
' End If
'' Next
For i = 1 To LR
DA(CStr(R(i, 1).value)) = CStr(R(i, 2).value)
DB(CStr(R(i, 2).value)) = CStr(R(i, 1).value)
Next
Do Until DB.Count <= 0
If DA.exists(DB.Keys(0)) Then
k = k + 1
FSO.MoveFolder Path & DB.Keys(0), Path & Z & k
DB(DA.item(DB.Keys(0))) = Z & k
DA.Remove DB.Keys(0): DA.Remove DB.Items(0)
End If
FSO.MoveFolder Path & DB.Items(0), Path & DB.Keys(0)
If DA.exists(DB.Items(0)) Then DA.Remove DB.Items(0)
DB.Remove DB.Keys(0)
Loop
Set DA = Nothing
Set DB = Nothing
Set FSO = Nothing
End Sub
