Soru Klasör Adı Okuma ve Yeniden Adlandırma Makrosu

[FİKİRCİBEY-]

Örneğin 1000 tane klasör isimlerinin önünde numara yazdığını düşünün 500 no.lu klasör iptal oldu. 499'dan 501'e atlıyor, 501 ve sonrasında bulunan 500 tane klasörün numaralarını bir eksiltip tek tek değiştirmek çok fazla vakit alan bir şey.

Bunun yerine klasörlerin bulunduğu ana klasörü hedef olarak seçip içindeki tüm klasörlerin adını bir sütuna getirip yanındaki sütunda yeni isimlerinin olduğu bir sütun olacak şekilde klasör değiştirme şeklinde makro yapılabilir mi acaba?
Teşekkürler.

 

[PLİNT]

Merhaba
Ek dosyayı deneyin
Adları değişecek klasörlerin bulunduğu ana klasörün adını seçmeniz yeterli. Klasör sayısı 4 haneden fazla olmasın, asıl klasörlerinizde denerken yedekleyin
https://www.dosyaupload.com/ftNZ

Private Sub CommandButton1_Click()
Dim s As Long, a As Long, c As Long, klas, yol As String
Dim klasorsec, nesne, klasor, klasorler
Dim ad As String, sor
[A:C] = ""
Set klasorsec = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", 0, ThisWorkbook.Path)
yol = klasorsec.Items.Item.Path
Set nesne = CreateObject("Scripting.FileSystemObject")
Set klasor = nesne.GetFolder(yol)
Set klasorler = klasor.Subfolders
For Each klas In klasorler
s = s + 1
Cells(s, 1) = klas.Name
Cells(s, 2) = RetNum(Left(klas.Name, 4))
Next
a = Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:D" & a).Sort Key1:=Cells(1, 2), Order1:=xlAscending
sor = MsgBox("Adlar değiştirilecek", vbYesNo)
If sor = vbNo Then MsgBox "İşlem iptal": Exit Sub
For c = 1 To a
Cells(c, "C") = Replace(Cells(c, "A"), RetNum(Left(Cells(c, "A"), 4)), c)
Name yol & "\" & Cells(c, "A") As yol & "\" & Cells(c, "C")
Next
MsgBox "İşlem Tamam"
End Sub
Function RetNum(AnyStr As String)
    Dim RegEx
    Set RegEx = CreateObject("vbscript.regexp")
    With RegEx
        .Global = True
        .Pattern = "[^\d]+"
    End With
    RetNum = RegEx.Replace(AnyStr, "")
    Set RegEx = Nothing
End Function

 

[FİKİRCİBEY-]

Merhaba
Ek dosyayı deneyin
Adları değişecek klasörlerin bulunduğu ana klasörün adını seçmeniz yeterli. Klasör sayısı 4 haneden fazla olmasın, asıl klasörlerinizde denerken yedekleyin
https://www.dosyaupload.com/ftNZ

Private Sub CommandButton1_Click()
Dim s As Long, a As Long, c As Long, klas, yol As String
Dim klasorsec, nesne, klasor, klasorler
Dim ad As String, sor
[A:C] = ""
Set klasorsec = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", 0, ThisWorkbook.Path)
yol = klasorsec.Items.Item.Path
Set nesne = CreateObject("Scripting.FileSystemObject")
Set klasor = nesne.GetFolder(yol)
Set klasorler = klasor.Subfolders
For Each klas In klasorler
s = s + 1
Cells(s, 1) = klas.Name
Cells(s, 2) = RetNum(Left(klas.Name, 4))
Next
a = Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:D" & a).Sort Key1:=Cells(1, 2), Order1:=xlAscending
sor = MsgBox("Adlar değiştirilecek", vbYesNo)
If sor = vbNo Then MsgBox "İşlem iptal": Exit Sub
For c = 1 To a
Cells(c, "C") = Replace(Cells(c, "A"), RetNum(Left(Cells(c, "A"), 4)), c)
Name yol & "\" & Cells(c, "A") As yol & "\" & Cells(c, "C")
Next
MsgBox "İşlem Tamam"
End Sub
Function RetNum(AnyStr As String)
    Dim RegEx
    Set RegEx = CreateObject("vbscript.regexp")
    With RegEx
        .Global = True
        .Pattern = "[^\d]+"
    End With
    RetNum = RegEx.Replace(AnyStr, "")
    Set RegEx = Nothing
End Function

İlginiz için teşekkür ederim.
Fakat klasörleri okuttuğumda bana klasörler için yeniden isim girme fırsatı vermeden klasör isimleri değiştirildi şeklinde mesaj kutusu açılıyor.
Ben bu makroyu sadece klasör numaralarını değiştirmek için değil klasör isimlerini genel olarak değiştirme işlemlerinde kullanmayı düşünüyorum, bu numara olur yeniden farklı bir isimlendirme olur bu tür işlerde kullanacağım desem daha doğru olur.

 

[halit3]

Alternatif olarak aşağıdaki linki irdeleyiniz.

Klasör isim değiştirme,kopyalama,taşıma Makro Çalışması

Merhabalar, Ekli dosyada yapılması gerekenleri aşağıda detaylarını yazdığım gibi işlemleri yapa bilecek bir makro çalışmasına ihtiyacımız vardır. Buton ekleye bilinirse çok daha kolay olur bizler için.. Yardımlarınızı bekliyoruz. İSİMLER = Kaynak klasör yolunu gösterip o yolun içerisinde...

excel.web.tr

 

[FİKİRCİBEY-]

Alternatif olarak aşağıdaki linki irdeleyiniz.

Klasör isim değiştirme,kopyalama,taşıma Makro Çalışması

Merhabalar, Ekli dosyada yapılması gerekenleri aşağıda detaylarını yazdığım gibi işlemleri yapa bilecek bir makro çalışmasına ihtiyacımız vardır. Buton ekleye bilinirse çok daha kolay olur bizler için.. Yardımlarınızı bekliyoruz. İSİMLER = Kaynak klasör yolunu gösterip o yolun içerisinde...

excel.web.tr

Çok teşekkürler hocam aradığım buydu