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

meleklerim

meleklerim

Altın Üye
Katılım
2 Ekim 2013
Mesajlar
347
Excel Vers. ve Dili
ofis 2019 türkçe
windows 10 pro türkçe
Altın Üyelik Bitiş Tarihi
23-07-2025
halit3' Alıntı:
Dosyalarınız bu şekilde devam ediyorsa yani arada bir boşluk var boşluktan sonraki sayı var ise bu kodları bir dene
Kod: 
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
Genişletmek için tıkla ...
Malesef Halit Bey,
Klasörde Dosyadı 1,2,3,....10.11.12....20
Listelenen Dosyaadı 1,10,20,2,3....

35 nolu mesajda eklediğim örnek dosya üzerinde deneseniz de upload yapsanız mümkün mü acaba? Belki ben kodalrı eklerken hata yapıyorumdur.
Altın üye olmadığım için diğer üyelere gönderdiğiniz ekli dosyalara ulaşamıyorum

Çoğunlukla dosyalarımın adı şu şekildedir
Zeytin tepesi 1. Bölüm
Zeytin tepesi 2. Bölüm
Zeytin tepesi 100. Bölüm

Sizi de çok yordum kusura bakmayın
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,822
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
meleklerim' Alıntı:
Malesef Halit Bey,
Klasörde Dosyadı 1,2,3,....10.11.12....20
Listelenen Dosyaadı 1,10,20,2,3....

35 nolu mesajda eklediğim örnek dosya üzerinde deneseniz de upload yapsanız mümkün mü acaba? Belki ben kodalrı eklerken hata yapıyorumdur.
Altın üye olmadığım için diğer üyelere gönderdiğiniz ekli dosyalara ulaşamıyorum

Çoğunlukla dosyalarımın adı şu şekildedir
Zeytin tepesi 1. Bölüm
Zeytin tepesi 2. Bölüm
Zeytin tepesi 100. Bölüm

Sizi de çok yordum kusura bakmayın
Genişletmek için tıkla ...
Ben farklı sitelere dosya eklemiyorum kodları burada paylaşıyorum.
bu kodları bir modülün içine kopyala
Kod: 
Function RegExpReplace(ByVal WhichString As String, _
ByVal Pattern As String, _
ByVal ReplaceWith As String, _
Optional ByVal IsGlobal As Boolean = True, _
Optional ByVal IsCaseSensitive As Boolean = True) As String
'Declaring the object
Dim objRegExp As Object
'Initializing an Instance
Set objRegExp = CreateObject("vbscript.regexp")
'Setting the Properties
objRegExp.Global = IsGlobal
objRegExp.Pattern = Pattern
objRegExp.IgnoreCase = Not IsCaseSensitive
'Execute the Replace Method
RegExpReplace = objRegExp.Replace(WhichString, ReplaceWith)

End Function
Function sayıayır(ByVal WhichString As String) As Variant
sayıayır = RegExpReplace(WhichString, _
"[^0-9]", vbNullString, True)
End Function
bu kodlarıda sayfanın kod bölümüne kopyala

Kod: 
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

Cells(j, 2) = Val(9 & sayıayır(fL.GetBaseName(Dosya.Name)))
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
 

Ekli dosyalar

meleklerim

meleklerim

Altın Üye
Katılım
2 Ekim 2013
Mesajlar
347
Excel Vers. ve Dili
ofis 2019 türkçe
windows 10 pro türkçe
Altın Üyelik Bitiş Tarihi
23-07-2025
halit3' Alıntı:
Ben farklı sitelere dosya eklemiyorum kodları burada paylaşıyorum.
bu kodları bir modülün içine kopyala
Kod: 
Function RegExpReplace(ByVal WhichString As String, _
ByVal Pattern As String, _
ByVal ReplaceWith As String, _
Optional ByVal IsGlobal As Boolean = True, _
Optional ByVal IsCaseSensitive As Boolean = True) As String
'Declaring the object
Dim objRegExp As Object
'Initializing an Instance
Set objRegExp = CreateObject("vbscript.regexp")
'Setting the Properties
objRegExp.Global = IsGlobal
objRegExp.Pattern = Pattern
objRegExp.IgnoreCase = Not IsCaseSensitive
'Execute the Replace Method
RegExpReplace = objRegExp.Replace(WhichString, ReplaceWith)

End Function
Function sayıayır(ByVal WhichString As String) As Variant
sayıayır = RegExpReplace(WhichString, _
"[^0-9]", vbNullString, True)
End Function
bu kodlarıda sayfanın kod bölümüne kopyala

Kod: 
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

Cells(j, 2) = Val(9 & sayıayır(fL.GetBaseName(Dosya.Name)))
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
Genişletmek için tıkla ...
Çok teşekkürler Halit Bey, sayenizde büyük bir iş yükünü hatasız ve seri yapabilme imkanına kavuştum.
Kullandıkça sizi hatırlayacağım :)
 
S

subutayı

Katılım
18 Mayıs 2005
Mesajlar
395
Excel Vers. ve Dili
Excel 2019 TR
Altın Üyelik Bitiş Tarihi
12-02-2024
halit bey,
mesaj 39 da vermiş olduğunuz dosyayı indirdim. liste adında bir klasörüm ve içinde 530 adet mp4 uzantılı videolarım var. 39. mesajdaki excel dosyanızı indirdim dosyaları bul komut düğmesine tıkladım. bütün dosya yollarını A sütünuna ve dosya isimlerini B sütünuna ekledi. C sütünuna da ben yeni dosya adlarını yazdım. dosya adlarını değiştir komut düğmesine tıkladım ve onay verdim. şu hatayı aldım. run time error 53 file not found. Debug a tıklayınca
Name eski As Yeni kod satırında takılı kaldı. çözümü nedir.
teşekürler...
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,580
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Dosya adında uygun olmayan karakter kullanmış olabilirsiniz. Kontrol ediniz.
 
S

subutayı

Katılım
18 Mayıs 2005
Mesajlar
395
Excel Vers. ve Dili
Excel 2019 TR
Altın Üyelik Bitiş Tarihi
12-02-2024
korhan bey teşekürler. hatalı dosyayı bulmaya çalışacağım. kolay gelsin.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,580
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Kodun hata veren satırı üzerine mouse ile geldiğinizde aldığı değeri gösterecektir.
 
S

subutayı

Katılım
18 Mayıs 2005
Mesajlar
395
Excel Vers. ve Dili
Excel 2019 TR
Altın Üyelik Bitiş Tarihi
12-02-2024
korhan bey şu an işteyim. dosyalar evdeki pc de akşam kontrol edip size dönüş yapacağım teşekürler....
 
S

subutayı

Katılım
18 Mayıs 2005
Mesajlar
395
Excel Vers. ve Dili
Excel 2019 TR
Altın Üyelik Bitiş Tarihi
12-02-2024
Korhan bey,
hata dosya adlarından kaynaklanıyormuş. Teşekkür ederim..
 
Y

yyhy

Altın Üye
Katılım
3 Aralık 2005
Mesajlar
924
Excel Vers. ve Dili
Microsoft Office 2021 TR
Microsoft 365 TR
Altın Üyelik Bitiş Tarihi
20-03-2029
Konu açılınca en azından bir örnek dosya eklense daha iyi olur diye düşünüyoruz. Dosya sonraki sayfalarda eklenmiş. Tüm excel.web.tr ailesine teşekkür ederim.
 
halit3

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,822
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
yyhy' Alıntı:
Arkadaşlardan rica etsek acaba dosya eklenebilir mi? Foruma giren arkadaşlar da en azından örnek dosyalardan yararlansa iyi olur. Tüm excel.web.tr ailesine teşekkür ederim..
Genişletmek için tıkla ...
22, 39, 42 nolu mesajlarda dosyalar mevcut
 
N

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,420
Excel Vers. ve Dili
Ofis 365 Türkçe
Merhaba,
Aşağıdaki örnek kodlar da benim yoğurt yiyişim :)

Bu Kod Dizini Bulur ve A1 hücresine dizin adını yazar.

Kod: 
Sub DosyaYoluBul()

    Dim fd As FileDialog
    Dim vrtSelectedItem As Variant

    Set fd = Application.FileDialog(msoFileDialogFolderPicker)

    With fd

        If .Show = -1 Then

            For Each vrtSelectedItem In .SelectedItems
                Range("A1") = vrtSelectedItem & Application.PathSeparator
                Liste Range("A1").Text
            Next vrtSelectedItem
           
        End If
       
    End With

    Set fd = Nothing

End Sub
Bu kod Bulunan Dizindeki Dosyaları Listeler, Otomatik çağrılır, ilk kod bunu yapar.

Kod: 
Sub Liste(Yol As String)

    Dim dosya As String, i As Long

    Application.ScreenUpdating = False
    i = Cells(Rows.Count, "A").End(3).Row
    If i < 2 Then i = 2
    Range("A2:B" & i).ClearContents
   
    dosya = Dir(Yol & "*.*")
    i = 1
    While dosya <> ""
        DoEvents
        i = i + 1
        Cells(i, 1) = dosya
        dosya = Dir
    Wend
   
End Sub
Aşağıdaki kodlar ise A sütununda listelenen (Uzantıları ile birlikte) B sütunundaki yeni adı ile değiştirilir. Yeni adı yazarken uzantıyı yazmaya gerek yok, çünkü A sütunundan uzantıyı otomatik olarak alır. B sütunundaki hücre boş ise karşılığındaki A sütunundaki dosyada değişiklik yapmaz.

Kod: 
Sub Degistir()

    Dim DsyBas  As String, _
        i       As Long, _
        j       As Integer, _
        Adt     As Integer, _
        Uzn     As String, _
        Uzanti  As String, _
        Yol     As String
           
    Uzn = Application.InputBox("Uzantısı Olmayan Dosyaların Uzantısı Ne Olsun?", "Sordum Gitti Valla", ".mp4", Type:=2)
   
    Yol = Application.WorksheetFunction.Trim(Range("A1"))
    If Not Right(Yol, 1) = "\" Then Yol = Yol & Application.PathSeparator
   
    For i = 2 To Cells(Rows.Count, "A").End(3).Row
   
        If Not Cells(i, "B") = "" Then
       
            Adt = Adt + 1
            j = InStr(1, StrReverse(Cells(i, "A")), ".", vbTextCompare)
            If j > 0 Then
                Uzanti = Right(Cells(i, "A"), j)
            Else
                Uzanti = Uzn
            End If
               
            Name Yol & Cells(i, "A") As Yol & Cells(i, "B") & Uzanti
           
        End If
       
    Next i
   
    MsgBox Adt & " ADET DOSYA ADI DEĞİŞTİRİLDİ...", vbInformation, "NECDET YEŞERTENER"
   
End Sub
 
Son düzenleme:
Y

yyhy

Altın Üye
Katılım
3 Aralık 2005
Mesajlar
924
Excel Vers. ve Dili
Microsoft Office 2021 TR
Microsoft 365 TR
Altın Üyelik Bitiş Tarihi
20-03-2029
Sayın halit3 sonradan fark ettim ek dosyaları gördüm. Cevap yazımı düzenledim. Tüm excel web tr ailesine teşekkürler.
 
T

Tevfik_Kursun

Altın Üye
Katılım
30 Temmuz 2012
Mesajlar
3,815
Excel Vers. ve Dili
Office 2016 Pro - Türkçe 64 Bit
Altın Üyelik Bitiş Tarihi
12-02-2029
Sayın Askm, Sayın Halit3 ve Necdet Hocalarım,
Her üçünüze de ayrı ayrı teşekkür ederim.
Saygılarımla
 
D

denese

Altın Üye
Katılım
17 Mart 2011
Mesajlar
441
Excel Vers. ve Dili
Office 2019
Altın Üyelik Bitiş Tarihi
02-03-2026
halit3' Alıntı:
kod:
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

Kod: 
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
Genişletmek için tıkla ...
Sayın @halit3 emeklerinize sağlık, dar zamanımda büyük kolaylık oldu.
 
PriveT

PriveT

Katılım
8 Ekim 2009
Mesajlar
642
Excel Vers. ve Dili
Office 2010 & 2016 TR
Altın Üyelik Bitiş Tarihi
26-12-2023
Arşivlik paylaşımlar. Emeklerinize sağlık.
 
T

tuncismet

Katılım
11 Ekim 2006
Mesajlar
56
Excel Vers. ve Dili
Excel 2010
Altın Üyelik Bitiş Tarihi
23/02/2022
Kodlar latin alfabesine göre mükemmel çalışıyor.Diğer alfabelerde çalışmıyor. Diğer alfabelerde de çalışırsa çok daha iyi olacak . Şimdiden teşekkürler
 
M

mikail.polat

Katılım
28 Ağustos 2012
Mesajlar
1
Excel Vers. ve Dili
Ofiice 2007 Türkçe
ELİNİZE SAĞLIK BİR KAÇ SİTEDEN TOPLADIĞIM KODLAR İLE EXCEL DE QR CODE YAPIP DOSYA İSİMLERİNİ DİLEDİĞİM GİBİ DEĞİŞTİREBİLDİM. TEŞEKKÜRLER...
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst