• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

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

  • deneme1.jpg
    deneme1.jpg
    221.2 KB · Görüntüleme: 20
  • deneme2.jpg
    deneme2.jpg
    163.7 KB · Görüntüleme: 21
  • deneme3.jpg
    deneme3.jpg
    179.5 KB · Görüntüleme: 20
  • Dosyaların adlarını toplu değiştir 3.xls
    Dosyaların adlarını toplu değiştir 3.xls
    250.5 KB · Görüntüleme: 78
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 :)
 
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...
 
Dosya adında uygun olmayan karakter kullanmış olabilirsiniz. Kontrol ediniz.
 
korhan bey teşekürler. hatalı dosyayı bulmaya çalışacağım. kolay gelsin.
 
Kodun hata veren satırı üzerine mouse ile geldiğinizde aldığı değeri gösterecektir.
 
korhan bey şu an işteyim. dosyalar evdeki pc de akşam kontrol edip size dönüş yapacağım teşekürler....
 
Korhan bey,
hata dosya adlarından kaynaklanıyormuş. Teşekkür ederim..
 
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.
 
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
 
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:
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.
 
Sayın Askm, Sayın Halit3 ve Necdet Hocalarım,
Her üçünüze de ayrı ayrı teşekkür ederim.
Saygılarımla
 
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.
 
Arşivlik paylaşımlar. Emeklerinize sağlık.
 
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
 
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.
Geri
Üst