Klasörlerdeki Türkçe karakterleri değiştirmek

[k0081]

Merhaba arkadaşlar;

Aktif klasör ve alt klasörlerin isimlerinde bulunan Türkçe karakterleri, commandbuton kullanarak nasıl değiştirebilirim ?

Eski_Karakter = Array("İ", "Ç", "Ğ", "Ö", "Ş", "Ü", "ı", "ç", "ğ", "ş", "ü", "ö")
Yeni_Karakter = Array("I", "C", "G", "O", "S", "U", "i", "c", "g", "s", "u", "o")

Yardımcı arkadaşa şimdiden Teşekkürler..

 

[halit3]

kodları sayfanın kod bölümüne kopyala ve 3 adet commadbutton ekle
sırası ile çalıştır birinci düğme değiştirilecek klasör ve alt klasörleri seçiyor ikinci düğme klasör adlarını değiştiriyor üçüncü düğme işlemi geri alıyor.

Private Sub CommandButton1_Click()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla


Range("a2:E65000").ClearContents


If Len(Kaynak) <= 3 Then
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
End If

Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")


j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("a2:a" & Rows.Count)) + 2
Cells(j, 1).Value = Kaynak
Cells(j, 2).Value = fL.GetBaseName(Kaynak)

Liste (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub


Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("a2:a" & Rows.Count)) + 2
Cells(j, 1).Value = f.Path
Cells(j, 2).Value = fL.GetBaseName(f.Path)
Cells(j, 4).Value = ""
Liste (f.Path)

sonraki:
Next

Set fL = Nothing

End Sub

Private Sub CommandButton2_Click()
Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

a = MsgBox(" Dosyaların isimlerini değiştirmek İstiyormusunz ?", vbExclamation + vbYesNo, "İşlem Tamam !")
If a = vbNo Then
Exit Sub
End If

For i = Worksheets(ActiveSheet.Name).Cells(Rows.Count, "A").End(3).Row To 2 Step -1
If Worksheets(ActiveSheet.Name).Cells(i, 4).Value <> "X" Then
eski = Worksheets(ActiveSheet.Name).Cells(i, 1).Value ' & "\" & Worksheets(ActiveSheet.Name).Cells(i, 2).Value & "." & Worksheets(ActiveSheet.Name).Cells(i, 3).Value


Worksheets(ActiveSheet.Name).Cells(i, 5).Value = Worksheets(ActiveSheet.Name).Cells(i, 1).Value


Eski_Karakter = Array("İ", "Ç", "Ğ", "Ö", "Ş", "Ü", "ı", "ç", "ğ", "ş", "ü", "ö")
Yeni_Karakter = Array("I", "C", "G", "O", "S", "U", "i", "c", "g", "s", "u", "o")
Worksheets(ActiveSheet.Name).Cells(i, 3).Value = Worksheets(ActiveSheet.Name).Cells(i, 2).Value
For s = 1 To 11
Worksheets(ActiveSheet.Name).Cells(i, 3).Value = Replace(Worksheets(ActiveSheet.Name).Cells(i, 3).Value, Eski_Karakter(s), Yeni_Karakter(s))
Next s


yeni = fL.GetParentFolderName(Worksheets(ActiveSheet.Name).Cells(i, 1).Value) & "\" & Worksheets(ActiveSheet.Name).Cells(i, 3).Value


fL.MoveFolder eski, yeni

Worksheets(ActiveSheet.Name).Cells(i, 1).Value = yeni
deg = Worksheets(ActiveSheet.Name).Cells(i, 3).Value
'Worksheets(ActiveSheet.Name).Cells(i, 3).Value = Worksheets(ActiveSheet.Name).Cells(i, 2).Value
'Worksheets(ActiveSheet.Name).Cells(i, 2).Value = deg
Worksheets(ActiveSheet.Name).Cells(i, 4).Value = "X"
End If
Next i
MsgBox "işlem tamam"
End Sub


Private Sub CommandButton3_Click()
Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

sat1 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A2:A65000"))
sat2 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("C2:C65000"))
If sat1 <> sat2 Then
MsgBox "eski dosyalarla değiştirilecek dosyalar sayısı aynı değil", vbInformation, "İşlem Tamam !"
End If
a = MsgBox(" Dosyaların isimlerini değiştirmek İstiyormusunz ?", vbExclamation + vbYesNo, "İşlem Tamam !")
If a = vbNo Then
Exit Sub
End If

For i = 2 To Worksheets(ActiveSheet.Name).Cells(Rows.Count, "A").End(3).Row
If Worksheets(ActiveSheet.Name).Cells(i, 4).Value = "X" Then

'eski = Worksheets(ActiveSheet.Name).Cells(i, 1).Value
'yeni = fL.GetParentFolderName(Worksheets(ActiveSheet.Name).Cells(i, 1).Value) & "\" & Worksheets(ActiveSheet.Name).Cells(i, 2).Value

eski = Worksheets(ActiveSheet.Name).Cells(i, 1).Value
yeni = Worksheets(ActiveSheet.Name).Cells(i, 5).Value


fL.MoveFolder eski, yeni
Worksheets(ActiveSheet.Name).Cells(i, 1).Value = yeni
deg = Worksheets(ActiveSheet.Name).Cells(i, 3).Value
Worksheets(ActiveSheet.Name).Cells(i, 3).Value = Worksheets(ActiveSheet.Name).Cells(i, 2).Value
Worksheets(ActiveSheet.Name).Cells(i, 2).Value = deg
Worksheets(ActiveSheet.Name).Cells(i, 4).Value = ""
Worksheets(ActiveSheet.Name).Cells(i, 5).Value = ""
End If
Next i
MsgBox "işlem tamam"
End Sub

 

[k0081]

Halit3;

Hocam teşekkürler. Kodlamayı Excel hücrelerini kullanmadan, güncelleme şansımız var mıdır ?

yani ; Worksheets, Cells, ActiveSheet.Name gibi. bu ifadeleri kullanmadan yapılabilir mi ?

 

[halit3]

kod:

Dim eski(5000)
Dim yeni(5000)
Dim say

Private Sub CommandButton1_Click()

Dim fL As Object, fs As Object, i As Long
Set fL = CreateObject("Scripting.FileSystemObject")
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
say = 0
If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
Liste (Kaynak)
For i = say To 1 Step -1
If i = 1 Then Application.Wait (Now + TimeValue("00:00:01"))
'MsgBox eski(i) & Chr(10) & yeni(i)
fL.MoveFolder eski(i), yeni(i)
Next i
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject")
On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
say = say + 1
eski(say) = f.Path
veri = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(fL.GetBaseName(f.Path), "ç", "c"), "ğ", "g"), "ı", "i"), "ö", "o"), "ş", "s"), "ü", "u"), "Ç", "C"), "Ğ", "G"), "İ", "I"), "Ö", "O"), "Ş", "S"), "Ü", "U")
yeni(say) = fL.GetParentFolderName(f.Path) & "\" & veri
Liste (f.Path)
sonraki:
Next
Set fL = Nothing

End Sub

 

[k0081]

halit3

Hocam çok teşekkür ediyorum tamamdır.. elinize-Yüreğinize sağlık.

 

[halit3]

halit3

Hocam çok teşekkür ediyorum tamamdır.. elinize-Yüreğinize sağlık.

Teşekkürler iyi çalışmalar