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

meleklerim

Altın Üye
Katılım
2 Ekim 2013
Mesajlar
293
Excel Vers. ve Dili
ofis 2019 türkçe
windows 10 pro türkçe
Bir klasörde bulunan dosya isimlerinin excel de A2 sütunundan başlayarak listelenmesini ve akabinde B2 sütunundaki isimlerle değiştirilmesini içeren 2 adet makroya ihtiyacım var (1-Listele, 2-Değiştir)
Makroların bulunduğu klasörde çalışması yerine gözat ile gösterilen klasörde işlem yapması daha çok kullanışlı olur benim için. (excel dosyasını habire farklı klasörlere taşımak zorunda kalmam)
Not:Listelenecek dosyaların uzantılarını dikkate almaması gerekiyor (uzantıların çoğu 4 ".mp3" karakter, ama bazıları ise 3 ".ts"

Yardımlarınız için şimdiden teşekkürler
 

Ömer BARAN

Uzman
Katılım
8 Mart 2011
Mesajlar
13,002
Excel Vers. ve Dili
Office 2013 ( 32 bit ) TÜRKÇE
Merhaba.

Forum sayfalarının üst sağ kısmında bulunan ARA alanına klasör liste yazarak arama yaparsanız,
birçok çözümlü örneğe ulaşabilirsiniz.
.
 

meleklerim

Altın Üye
Katılım
2 Ekim 2013
Mesajlar
293
Excel Vers. ve Dili
ofis 2019 türkçe
windows 10 pro türkçe
Merhaba.

Forum sayfalarının üst sağ kısmında bulunan ARA alanına klasör liste yazarak arama yaparsanız,
birçok çözümlü örneğe ulaşabilirsiniz.
.
Malesef bulduklarım Altın üyelik istiyor ve kimi sadece listeleme kimi de sadece değiştirme işlevi içeriyor. Böyle bir konu bulamadım
 

askm

Destek Ekibi
Destek Ekibi
Katılım
4 Haziran 2005
Mesajlar
2,745
Excel Vers. ve Dili
2010-2016
Aşağıdaki kodları deneyin.
Kod:
Sub Dosya_Listeleme()
    Dim I As Long
    Dim xFileName As String
    Dim xFileDlg As FileDialog
    Dim xFileDlgItem As Variant
    On Error Resume Next
  I = 1
    Cells(I, 1).Value = "Dosya Adı"
    With Cells(I, 1).Font
    .Name = "Arial"
    .FontStyle = "Bold"
    .Size = 10
    End With
    Cells(I, 1).EntireColumn.AutoFit
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
  
    If xFileDlg.Show = -1 Then
        xFileDlgItem = xFileDlg.SelectedItems.Item(1)
        xFileName = Dir(xFileDlgItem & "\")
        Do While xFileName <> ""
                I = I + 1
                Cells(I, 1).Value = xFileName
                xFileName = Dir
        Loop
    End If
    Columns("A").AutoFit
    Application.ScreenUpdating = True
End Sub
 

meleklerim

Altın Üye
Katılım
2 Ekim 2013
Mesajlar
293
Excel Vers. ve Dili
ofis 2019 türkçe
windows 10 pro türkçe
Yardımız için teşekkürler,
Ancak
1- Sadece Listeleme makrosu var. (ben bir de değiştir makrosu istemiştim)
2-Listelenirken dosyaların uzantısını da listeliyor. Ben uzantıların listelenmesini istemiyorum. Sadece dosya adı listelensin

tekrar teşekkürler
 
Son düzenleme:

askm

Destek Ekibi
Destek Ekibi
Katılım
4 Haziran 2005
Mesajlar
2,745
Excel Vers. ve Dili
2010-2016
Listeleme aşağıdaki şekilde deneyin. Değiştirme için örnek dosya ekleyin bakalım. (Yanında örnek bir kaç dosya ile birlikte)
Kod:
Sub Dosya_Listeleme()
    Dim I As Long
    Dim xFileName As String
    Dim xFileDlg As FileDialog
    Dim xFileDlgItem As Variant
    On Error Resume Next
  I = 1
    Cells(I, 1).Value = "Dosya Adı"
    With Cells(I, 1).Font
    .Name = "Arial"
    .FontStyle = "Bold"
    .Size = 10
    End With
    Cells(I, 1).EntireColumn.AutoFit
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
  
    If xFileDlg.Show = -1 Then
        xFileDlgItem = xFileDlg.SelectedItems.Item(1)
        xFileName = Dir(xFileDlgItem & "\")
        Do While xFileName <> ""
                I = I + 1
                DosyaAdi = Split(xFileName, ".")(0)
                Cells(I, 1).Value = DosyaAdi
                xFileName = Dir
        Loop
    End If
    Columns("A").AutoFit
    Application.ScreenUpdating = True
End Sub
 

Ömer BARAN

Uzman
Katılım
8 Mart 2011
Mesajlar
13,002
Excel Vers. ve Dili
Office 2013 ( 32 bit ) TÜRKÇE
Listeleme aşağıdaki şekilde deneyin. Değiştirme için örnek dosya ekleyin bakalım. (Yanında örnek bir kaç dosya ile birlikte)
Kod:
Sub Dosya_Listeleme()
................
                DosyaAdi = Split(xFileName, ".")(0)
................
End Sub
Merhaba Sayın @askm . Emeğinize sağlık.
Belge adlarında da "." (NOKTA) karakteri kullanılabileceğinden,
sanıyorum yukarıdaki satırın sonundaki (0) kısmına küçük bir ilave yapılması gerekiyor.

Hatırlatayım dedim.
.
 

meleklerim

Altın Üye
Katılım
2 Ekim 2013
Mesajlar
293
Excel Vers. ve Dili
ofis 2019 türkçe
windows 10 pro türkçe
aynen :)
dosya adında bulunan "." dan sonrasını "." dahil kesti
Dosya adı 01.28.2018 yedek.xls iken onu 01 olarak listeledi.
Örnek dosya ekleyemiyorum çünkü klasör üzerinden işlem yapacak.
A2 ye listelediği klasördeki dosya isimlerini B2 deki isimle değiştirmesini istiyorum.
Örnek
A2 (Eski Dosya Adı)
01.28.2018 Yedek (Bunu gözatla kendi listeliyor zaten, makronuz (uzantı sorunu dışında) istediğim gibi çalışıyor)
B2 (Yeni Dosya Adı
Yedek 2018 (Bunu ben yazıyorum)
Değiştir makrosunu çalıştırdığımda listelenen klasördeki o dosyanın ismi değişmesi lazım
 
Son düzenleme:

Ömer BARAN

Uzman
Katılım
8 Mart 2011
Mesajlar
13,002
Excel Vers. ve Dili
Office 2013 ( 32 bit ) TÜRKÇE
.
Bence sağdan 3 ve 4'üncü karakter (uzantıların 3 veya 2 karakter olduğu daha önce belirtildiğinden)
"." karakteri yönünden kontrol edilip kalan kısmın alınması sağlanabilir.
Sayın @askm gerekli düzenlemeyi yapacaktır.
.
 

askm

Destek Ekibi
Destek Ekibi
Katılım
4 Haziran 2005
Mesajlar
2,745
Excel Vers. ve Dili
2010-2016
O kısmı atlamışım kusura bakmayın.
Kod:
Sub Dosya_Listeleme()
    Dim I As Long
    Dim xFileName As String
    Dim xFileDlg As FileDialog
    Dim xFileDlgItem As Variant
    On Error Resume Next
  I = 1
    Cells(I, 1).Value = "Dosya Adı"
    With Cells(I, 1).Font
    .Name = "Arial"
    .FontStyle = "Bold"
    .Size = 10
    End With
    Cells(I, 1).EntireColumn.AutoFit
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
  
    If xFileDlg.Show = -1 Then
        xFileDlgItem = xFileDlg.SelectedItems.Item(1)
        xFileName = Dir(xFileDlgItem & "\")
        Do While xFileName <> ""
                I = I + 1
                DosyaAdi = Split(xFileName, ".")
                Cells(I, 1).Value = Mid(xFileName, 1, Len(xFileName) - Len(DosyaAdi(UBound(DosyaAdi))) - 1)
                xFileName = Dir
        Loop
    End If
    Columns("A").AutoFit
    Application.ScreenUpdating = True
End Sub
 

askm

Destek Ekibi
Destek Ekibi
Katılım
4 Haziran 2005
Mesajlar
2,745
Excel Vers. ve Dili
2010-2016
B sütununa dosya isimlerini siz manuel mi yazacaksınız. 01.28.2018 yedek.xls satırının karşısında deneme doc ise dosyanız deneme doc olacak. xls uzantılı dosyayı doc yaparsanız dosyanız bozulacak.
 

meleklerim

Altın Üye
Katılım
2 Ekim 2013
Mesajlar
293
Excel Vers. ve Dili
ofis 2019 türkçe
windows 10 pro türkçe
harikasınız.
Listeleme makronuz sorunsuz çalışıyor. Elinize sağlık. Ne demek, kusura bakmayın, asıl siz kusura bakmayın, bizim gibi az bilenlere ışık oluyorsunuz.
Şimdi de bu listelenen dosya isimlerini değiştirilmesi makrosunu düzenleyebilir misiniz?
Tüm içtenliğimle çok teşekkür ederim
 

meleklerim

Altın Üye
Katılım
2 Ekim 2013
Mesajlar
293
Excel Vers. ve Dili
ofis 2019 türkçe
windows 10 pro türkçe
B sütununa dosya isimlerini siz manuel mi yazacaksınız. 01.28.2018 yedek.xls satırının karşısında deneme doc ise dosyanız deneme doc olacak. xls uzantılı dosyayı doc yaparsanız dosyanız bozulacak.
Evet A sutunundaki lsitelenen dosyaların YENİ ADINI B sutununa ben manuel yazacağım. Makro o klasördeki dosya isimlerini toplu halde değiştirecek.
Dosya adını değiştirirken de uzantılar işe dahil olmayacak. Olmaması lazım.
 

askm

Destek Ekibi
Destek Ekibi
Katılım
4 Haziran 2005
Mesajlar
2,745
Excel Vers. ve Dili
2010-2016
Uzantıları olmadan isim değiştirme yapmaz. Ayrıca dosya konumunu da bir yere not etmesi gerekli.
Eğer C1 e dosya konumunu ve alt satırlara da A sutununa yazdığı dosyaların uzantısını yazsın.
Aşağıdaki şekilde iki buton ile işleminizi yapabilirsiniz.
Kod:
Sub Dosya_Listeleme()
    Dim I As Long
    Dim xFileName As String
    Dim xFileDlg As FileDialog
    Dim xFileDlgItem As Variant
    On Error Resume Next
    Cells(1, 3).ClearContents
    Columns("A").ClearContents
    Columns("C").ClearContents
    Range("A1:C65536").Interior.Color = xlNone
  I = 1
    Cells(I, 1).Value = "Dosya Adı"
    With Cells(I, 1).Font
    .Name = "Arial"
    .FontStyle = "Bold"
    .Size = 10
    End With
    Cells(I, 1).EntireColumn.AutoFit
    Set xFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
   
    If xFileDlg.Show = -1 Then
        xFileDlgItem = xFileDlg.SelectedItems.Item(1)
        If Cells(1, 3) = Empty Then Cells(1, 3) = xFileDlgItem
        xFileName = Dir(xFileDlgItem & "\")
        Do While xFileName <> ""
                I = I + 1
                DosyaAdi = Split(xFileName, ".")
                Cells(I, 1).Value = Mid(xFileName, 1, Len(xFileName) - Len(DosyaAdi(UBound(DosyaAdi))) - 1)
                Cells(I, 3).Value = DosyaAdi(UBound(DosyaAdi))
                xFileName = Dir
        Loop
    End If
    Columns("A").AutoFit
    Application.ScreenUpdating = True
End Sub
Kod:
Sub Dosya_Ismi_Degistir()
Dim src As String, Eski_Ad As String, Yeni_Ad As String
Dim Uzanti As String
Dim son As Long
son = Range("A" & Rows.Count).End(3).Row

src = Range("C1")
On Error Resume Next
For I = 2 To son
    Eski_Ad = Cells(I, 1)
    Yeni_Ad = Cells(I, 2)
    Uzanti = Cells(I, 3)
    Name src & "\" & Eski_Ad & "." & Uzanti As src & "\" & Yeni_Ad & "." & Uzanti
    If Err.Number <> 0 Then
       Range("A" & I & ":C" & I).Interior.Color = vbRed
    End If
    On Error GoTo 0
Next I
End Sub
 
Son düzenleme:

Ömer BARAN

Uzman
Katılım
8 Mart 2011
Mesajlar
13,002
Excel Vers. ve Dili
Office 2013 ( 32 bit ) TÜRKÇE
Tekrar merhabalar.
İki husus hakkında fikrimi söyleyeyim;
-- SAYI olan dosya isimleri hücrelere doğal olarak SAYI şeklinde yazılıyor.
Görüntü bakımından düzgün bir yapı oluşması için;
ilgili alan METİN olarak biçimlendirilirse veya yazılacak değer METİN olarak hücreye yazılırsa bence daha güzel olur.
-- Kod ile ilgili olarak da (Sayın @askm 'ın verdiği son cevabı denemedim) bu tür konuya da pek aşina değilim ama,
kod'un ilgili kısmı aşağıdaki gibi değiştirildiğinde listeleme sorunsuz gerçekleşiyor.

Rich (BB code):
        Do While xFileName <> ""
                I = I + 1
                Set uzanti = CreateObject("Scripting.FileSystemObject")
                Cells(I, 1).Value = Replace(xFileName, "." & uzanti.GetExtensionName(xFileName), "")
                xFileName = Dir
        Loop
 

meleklerim

Altın Üye
Katılım
2 Ekim 2013
Mesajlar
293
Excel Vers. ve Dili
ofis 2019 türkçe
windows 10 pro türkçe
Sayın askm makronuz saat gibi çalışıyor. Süpersiniz. C sütunu da kurcalamamak adına gizledim.
Ömer Bey'in dediği de doğru, ilgili kısmı onun tavsiye ettiği gibi değiştirdim.
İşin güzel tarafı A sütunu en uzun dosya ismine göre otomatik olarak genişleyip daralıyor.
Elleriniz dert görmesin.
Allah hepinize zihin açıklığı versin
 

Ömer BARAN

Uzman
Katılım
8 Mart 2011
Mesajlar
13,002
Excel Vers. ve Dili
Office 2013 ( 32 bit ) TÜRKÇE
Ben bir şey yapmadım, Sayın @askm 'ın ellerine/emeğine sağlık.
İyi çalışmalar dilerim.
.
 

askm

Destek Ekibi
Destek Ekibi
Katılım
4 Haziran 2005
Mesajlar
2,745
Excel Vers. ve Dili
2010-2016
Rica ederim. Ömer Bey'in uzantı hatırlatması ve düzeltmesi olmasa yine eksik olacaktı. Ömer Bey teşekkür ederim.
 

halit3

Uzman
Uzman
Katılım
18 Ocak 2008
Mesajlar
12,758
Excel Vers. ve Dili
2003 excell türkçe
ve
2007 excell türkçe
Alternatif kod

Bu kod A Sutünuna dosyanın tam adresini yazıyor B sutünuna da dosya adını yazıyor.

Kod:
Private Sub CommandButton4_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:B65000").ClearContents
Range("D2:D65000").ClearContents
Worksheets(ActiveSheet.Name).Cells(1, 5).Value = "OK"
If Right(Kaynak, 1) <> "\" Then Kaynak = 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")

If Right(yol, 1) <> "\" Then ekle = "\"

On Error Resume Next
For Each Dosya In fL.GetFolder(yol).Files
j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("a1:a" & Rows.Count)) + 1
Cells(j, 1) = yol & ekle & Dosya.Name
Cells(j, 2) = fL.GetBaseName(Dosya.Name) 'dosya.Name
Next

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

Set fL = Nothing
End Sub
bu Kod B sutundaki dosya adını C sutünundaki dosya ismi ile değiştiriyor.

Kod:
Private Sub CommandButton2_Click()

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 'fL.GetBaseName(eski)
uzanti = "." & fL.GetExtensionName(eski)
yeni = Klasor & "\" & dosya_adi & uzanti

Name eski As yeni

Next i

MsgBox "işlem tamam"
End Sub
 

meleklerim

Altın Üye
Katılım
2 Ekim 2013
Mesajlar
293
Excel Vers. ve Dili
ofis 2019 türkçe
windows 10 pro türkçe
sayın halit3 Bu kodu sayfayı sağ tıklayıp kod görüntüle dedim ve çıkan alana yapıştırdım.
Sonra da bir şekil ekleyip bu şekle makro atamak istedim (her zaman yaptığım uygulama şekli)
ama burada yazılı makroları bu yöntemle göremedim. Sanırım bu gibi kodlar için başka bir yöntem uygulamam gerekiyor.
Yardımcı olur musunuz?
 
Üst