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

meleklerim · 21 Ekim 2018

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 · 21 Ekim 2018

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 · 21 Ekim 2018

Ömer BARAN' Alıntı:
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 · 21 Ekim 2018

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 · 21 Ekim 2018

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

askm · 21 Ekim 2018

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 · 21 Ekim 2018

askm' Alıntı:
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 · 21 Ekim 2018

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

Ömer BARAN · 21 Ekim 2018

.
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 · 21 Ekim 2018

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 · 21 Ekim 2018

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 · 21 Ekim 2018

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 · 21 Ekim 2018

askm' Alıntı:
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 · 21 Ekim 2018

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

Ömer BARAN · 21 Ekim 2018

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 · 22 Ekim 2018

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 · 22 Ekim 2018

Ben bir şey yapmadım, Sayın @askm 'ın ellerine/emeğine sağlık.
İyi çalışmalar dilerim.
.

askm · 22 Ekim 2018

Rica ederim. Ömer Bey'in uzantı hatırlatması ve düzeltmesi olmasa yine eksik olacaktı. Ömer Bey teşekkür ederim.

halit3 · 22 Ekim 2018

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 · 22 Ekim 2018

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?

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

meleklerim

Ömer BARAN

Uzman

meleklerim

askm

Destek Ekibi

meleklerim

askm

Destek Ekibi

Ömer BARAN

Uzman

meleklerim

Ömer BARAN

Uzman

askm

Destek Ekibi

askm

Destek Ekibi

meleklerim

meleklerim

askm

Destek Ekibi

Ömer BARAN

Uzman

meleklerim

Ömer BARAN

Uzman

askm

Destek Ekibi

halit3

Uzman

meleklerim