Klasördeki dosya adlarını yazdırma

[Erdinç FIRTINA]

Değerli forum üyeleri,
Bir klasör içindeki dosyaların adlarını her dosyanın b sütunu doluysa a sütununa yazdırmak istiyorum. Yardımlarınız için teşekkürler.
Yardımlarınız için şimdiden teşekkürler !!

(Örnek dosyalar ve klasör ektedir)

 

[asi_kral]

Merhaba
Sorunuzdan hiç bir şey anlamadım. Lütfen daha açık anlatabilir misiniz_?

 

[dEdE]

Merhaba,
Bu dosyayı ilgili klasörün içine atıp, butona tıklayınız.
Profilinizde Excel versiyonu 2003 yazıyor ama örnek dosyanız daha üst versiyon.
Ben üst versiyona göre hazırlanmış dosya ektedir.

Sub SayfaAdıYaz()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
yol = ThisWorkbook.Path & "\"
Set COfs = CreateObject("Scripting.FileSystemObject")

For Each Dosya In COfs.GetFolder(yol).Files
If Dosya.Name <> "Kaynak.xlsm" Then
    Set WBook = Workbooks.Open(yol & Dosya.Name)
    Son = WBook.Sheets(1).[B65536].End(3).Row
        For i = 1 To Son
            WBook.Sheets(1).Cells(i, 1).Value = Replace(Dosya.Name, "." & COfs.GetExtensionName(Dosya.Name), "")
        Next
    WBook.Close 1
End If
Next

Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "İşlem Tamam...", vbInformation, "dEdE Başarılar Diler..."
End Sub

 

[Erdinç FIRTINA]

Sayın dEdE,
Size nasıl teşekkür edeceğimi bilemiyorum. Yüreğinize, beyninize, bileğinize sağlık !!!

(Şimdi baktım, dolayısıyla teşekkürde çok gecikmiş oldum. Kusura kalmayın.)
Bir de, kaynak dosyayı xlsx veya xls yapmak istersem sadece aşağıdaki satırda xlsx olarak değiştiriyorum. Ama dosyayı kapatıp açtığımda yine uzantısı xlsm oluyor.

If Dosya.Name <> "Kaynak.xlsm" Then

Ayrıca kodu anlamaya çalışıyorum.
Şöyle anladım. Eğer B1 den başlayarak doluysa son hücredeki dolu satır kadar A sütununa dosya adı yazılıyor. Örneğin; K1 den başlayarak yazdırmak istersem Cells(i, 1) deki 1 i 11 yapmam yeterli midir ? Başkaca değişiklik yapmam gerekiyor mu?

 

[dEdE]

Merhaba,
Koddaki If Dosya.Name <> "Kaynak.xlsm" Then ve End if satırlarını silebilirsiniz. Sorun çıkarmaz. Ancak Kaynak dosyayı xlsx olarak kaydederseniz makro kodlarınız silinir. Çünkü .xlsx formatı makroyu desteklemez. Kaynak dosyayı farklı kaydet yoluyla .xls olarak kaydedebilirsiniz veya .xls olarak açılmış bir dosyaya kodları taşırsınız (yukarıda belirttiğim satırları siler veya .xls olarak değiştirirseniz) sorun olmaz.
K1 den başlayarak yazdırmak isterseniz 1 yerine 11 veya tırnak içinde "K" yazabilirsiniz.

 

[Erdinç FIRTINA]

Sayın dEdE,
Çok çok teşekkür ederim. Hiç bir karşılık beklemeden emeğini esirgemeyen siz ve diğer tüm üstadların yüreğine, beyine ve bileğine sağlık !!!

 

[Recep İpek]

Emeğim boşa gitmesin. Bende birşeyler yapmaya çalışmıştım. Sanırım geç kaldım.

Sub Kapalı_Dosya_Veri_Yaz()
Dim adet As Variant
Dim i, j, dosya, dosyax, Kontrol, Path
Dim wb As Object
adet = 0
adet = InputBox("Kaç defa yazdırılsın?", "Uyarı", 10)
Path = "C:\TestFolder\kapalı_dosyalar\"
If Not IsNumeric(adet) Then Exit Sub
For i = 1 To [a1000].End(3).Row
dosya = Cells(i, "a").Value
dosyax = dosya & ".xlsx"
Kontrol = Dir(Path & dosyax)
If Kontrol <> "" Then
    Set wb = Workbooks.Open(Path & dosyax)
    For j = 1 To adet
        wb.Sheets(1).Cells(j, "L").Value = dosya
    
    Next j
    wb.Close True
    Set wb = Nothing
End If
Next i
MsgBox "Veri yazma işlemi tamamlandı.", vbInformation + vbDefaultButton1 + vbOKOnly, "Bilgi"
End Sub

 

[Erdinç FIRTINA]

Sayın Recep İPEK,
Ben de daha dosyanıza bakmadım ama emeğiniz ve yardımlarınız için şimdiden çok çok teşekkür ederim.

 

[Erdinç FIRTINA]

Sayın Recep İPEK,
Kodları çalıştıramadım. Mümkünse bir bakabilir misiniz ?

 

[Recep İpek]

Path = "C:\TestFolder\kapalı_dosyalar\"

satırındaki klasör yolunu kendinize göre düzelttiniz mi?