Klasördeki Dosya İsimlerini Listeleme/Değiştirme

[halit3]

Ofis 2003 için Denetim araç çubuğu yukarıdaki nesnelere mause ile sağ tıklayın ve denetim araç çubuğunu işaretleyiniz.
denetim araç çubuğundan komut düğmesi ekleyeceksiniz.

 

[halit3]

kod:

Sub dosyaları_bul()
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

Worksheets(ActiveSheet.Name).Range("A2:B65000").ClearContents
Range("D2:D65000").ClearContents

Liste4 (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 Liste4(yol As String)
Dim fL As Object, f As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")

For Each Dosya In fL.GetFolder(yol).Files
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = Dosya
Cells(j, 2) = fL.GetBaseName(Dosya.Name)
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste4 (f.Path)
sonraki:
Next

End Sub

Sub dosyaların_adını_degistir()

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
eski = Worksheets(ActiveSheet.Name).Cells(i, 1).Value
Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")

Klasor = fL.GetParentFolderName(eski)
dosya_adi = Worksheets(ActiveSheet.Name).Cells(i, 3).Value 'fL.GetBaseName(eski)
uzanti = "." & fL.GetExtensionName(eski)
yeni = Klasor & "\" & dosya_adi & uzanti
Worksheets(ActiveSheet.Name).Cells(i, 4).Value = yeni
Name eski As yeni
Worksheets(ActiveSheet.Name).Cells(i, 4).Value = yeni
Next i

MsgBox "işlem tamam"
End Sub

 

[askm]

Gelişmiş kısmından buton eklemeniz gerekli ya da
Private Sub CommandButton2_Click()
kısmını sub deneme () sub b() gibi bir isimle vererek deneyin.

 

[vurkan]

Arkadaşlar merhaba. Sayın Askm nin kodlarını denediğimde dosya isimlerini değiştir kodlarını çalıştırınca;

Name src & "\" & Eski_Ad & "." & Uzanti As src & "\" & Yeni_Ad & "." & Uzanti satırında hata verip. A2 B2 ve C2 hücreleri kırmızı oluyor.
Dosyaları listele dediğimde A2 den itibaren listeliyor. B sütunu boş, C1 dosya yolunu yazıyor. Galiba C2 den itibaren dosya uzantılarını yazmıyor. Nasıl yapabiliirim. Teşekkürler.
http://s3.dosya.tc/server17/blc7gq/DOSYALARI_BUL_DEGISTIR_ASKM.rar.html

 

[askm]

Döngüyü aşağıdaki şekilde değiştirin.

Do While xFileName <> ""
                I = I + 1
                Set Uzanti = CreateObject("Scripting.FileSystemObject")
                Cells(I, 1).Value = Replace(xFileName, "." & Uzanti.GetExtensionName(xFileName), "")
                Cells(I, 3).Value = Uzanti.GetExtensionName(xFileName) 'bu satırı eklememişsiniz.
                xFileName = Dir
Loop

 

[vurkan]

Sayın Askm dediğiniz gibi döngüyü değiştirdim. Şimdi dosya uzantıları geliyor. Makroyu çalıştırıyorum, yine;

Name src & "\" & Eski_Ad & "." & Uzanti As src & "\" & Yeni_Ad & "." & Uzanti satırı sarı olup kalıyor. Ama bu arada dosya adları da değişmiş oluyor.. Saygılarımla.

 

[halit3]

Alternatif olarak 22 nolu mesajdaki dosyayı denediniz mi?

 

[vurkan]

Halit3 Üstadım sizin dosyanızda bir sorun yok. ben onu aldım. Teşekkür ediyorum.

 

[meleklerim]

her iki makroda sorunsuz çalışıyor bende, sadece halit kardeşimizin
(eksisi)makrosunda dosya bulma değiştirme işleminde 1. satır boş kalsaydı listeleme değiştirme işlemleri 2. satırdan başlasaydı (sütun başlıklarını yazabilme bakımından)
(artısı) birden fazla değiştirme işini sıraya ekleyip toplu halde yapılması

ellerinize sağlık

 

[tugkan]

@halit3 Hocam süper bir dosya

 

[halit3]

her iki makroda sorunsuz çalışıyor bende, sadece halit kardeşimizin
(eksisi)makrosunda dosya bulma değiştirme işleminde 1. satır boş kalsaydı listeleme değiştirme işlemleri 2. satırdan başlasaydı (sütun başlıklarını yazabilme bakımından)
(artısı) birden fazla değiştirme işini sıraya ekleyip toplu halde yapılması

ellerinize sağlık

Birinci satıra başlıkları yaz ve yeniden dene kod zaten ikinci satırdan başlıyor işlemlere

 

[halit3]

@halit3 Hocam süper bir dosya

Teşekkürler iyi çalışmalar

 

[meleklerim]

Birinci satıra başlıkları yaz ve yeniden dene kod zaten ikinci satırdan başlıyor işlemlere

Evet, sütunlar boşken 1. satırdan başlıyordu. Sütun başlığı yazınca 2. satırdan başladı.
Şöyle bir sorunla karşılaşıyorum
Dosyadan Listeleme yaparken klasördeki sıralama gibi sıralamıyor.
Yani diyelim listeleme yapılacak klasörde dosya isimleri
Dosyaadı 1
Dosyaadı 2
Dosyaadı 3
Dosyaadı 20
Dosyaadı 21
Dosyaadı 100
olsun
bunu excele listelerken
Dosyaadı 1
Dosyaadı 10
Dosyaadı 100
Dosyaadı 2
Dosyaadı 20
Dosyaadı 3

şeklinde listeliyor. Ben klasörde nasıl listelenmişse excele de öyle listelenmesini istiyorum.
mümkün mü?

 

[halit3]

Kodun bu bölümümünden sonra

Liste4 (Kaynak)

bu bölümü ekle

sson1 = Cells(Rows.Count, "a").End(3).Row
Range("A2:A" & sson1).Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

 

[meleklerim]

kodların son durumu böyle ama bir işe yaramadı.
hata mesajı veriyor kod 400
ve şimdi a1 satırını kullanıyor

örnek güncel dosya
http://s7.dosya.tc/server10/fj9dcr/Bul-Degistir.rar.html

Kodun bu bölümümünden sonra

Liste4 (Kaynak)

bu bölümü ekle

sson1 = Cells(Rows.Count, "a").End(3).Row
Range("A2:A" & sson1).Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

 

[assenucler]

Halit Bey,

22. iletideki dosyayı indirdikten sonra 34. iletideki kodu ekledim, aldığım kod resmini ekliyorum. Sarı ekteki kod bir hatayı mı gösteriyor?

 

[assenucler]

34. iletideki kodu kullanmadığım zaman, aldığım kod resmini ekliyorum. Sarı ekteki kod bir hatayı mı gösteriyor?

 

[halit3]

Dosyaadı 1
Dosyaadı 2
Dosyaadı 3
Dosyaadı 20
Dosyaadı 21
Dosyaadı 100

Dosyalarınız bu şekilde devam ediyorsa yani arada bir boşluk var boşluktan sonraki sayı var ise bu kodları bir dene

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
Worksheets(ActiveSheet.Name).Range("A2:B65000").ClearContents
Range("D2:D65000").ClearContents
Worksheets(ActiveSheet.Name).Cells(1, 5).Value = "OK"

Liste4 (Kaynak)

sson1 = Cells(Rows.Count, "a").End(3).Row
Range("A2:D" & sson1).Sort Key1:=Range("b2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")
For i = 2 To Worksheets(ActiveSheet.Name).Cells(Rows.Count, "A").End(3).Row
Worksheets(ActiveSheet.Name).Cells(i, 2).Value = fL.GetBaseName(Worksheets(ActiveSheet.Name).Cells(i, 1).Value)
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 Liste4(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long
Set fL = CreateObject("Scripting.FileSystemObject")


For Each Dosya In fL.GetFolder(yol).Files
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1
Cells(j, 1) = Dosya

deg1 = Split(fL.GetBaseName(Dosya.Name), " ")
If UBound(deg1) > 0 Then
Cells(j, 2).Value = Val(9 & deg1(1))
else
Cells(j, 2) = fL.GetBaseName(Dosya.Name)
End If
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste4 (f.Path)
sonraki:
Next

End Sub



Private Sub CommandButton2_Click()
If Worksheets(ActiveSheet.Name).Cells(1, 5).Value <> "OK" Then MsgBox "işlemi yeniden yapaın": Exit Sub
sat1 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A2:A65000"))
sat2 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("B2:B65000"))
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
eski = Worksheets(ActiveSheet.Name).Cells(i, 1).Value

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

Klasor = fL.GetParentFolderName(eski)
dosya_adi = Worksheets(ActiveSheet.Name).Cells(i, 3).Value
uzanti = "." & fL.GetExtensionName(eski)

yeni = Klasor & "\" & dosya_adi & uzanti
Worksheets(ActiveSheet.Name).Cells(i, 4).Value = yeni

Name eski As yeni
Worksheets(ActiveSheet.Name).Cells(i, 4).Value = yeni
Next i
Worksheets(ActiveSheet.Name).Cells(1, 5).Value = ""
Worksheets(ActiveSheet.Name).Cells(1, 4).Value = "OK"
MsgBox "işlem tamam"
End Sub


Private Sub CommandButton4_Click()
If Worksheets(ActiveSheet.Name).Cells(1, 4).Value <> "OK" Then MsgBox "işlemi yeniden yapaın": Exit Sub

sat1 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A2:A65000"))
sat2 = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("B2:B65000"))
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, "D").End(3).Row
eski = Worksheets(ActiveSheet.Name).Cells(i, 4).Value
yeni = Worksheets(ActiveSheet.Name).Cells(i, 1).Value
Name eski As yeni
Next i
Worksheets(ActiveSheet.Name).Cells(1, 4).Value = ""
Range("D2:D65000").ClearContents
MsgBox "işlem tamam"
End Sub

Private Sub CommandButton3_Click()
Range("A2:B65000").ClearContents
'Range("A2:F10").ClearContents
End Sub

 

[halit3]

34. iletideki kodu kullanmadığım zaman, aldığım kod resmini ekliyorum. Sarı ekteki kod bir hatayı mı gösteriyor?

kodlar bu dosyada

 

[assenucler]

Teşekkürler ve hayırlı geceler üstadım.