VBA_Excel Basic Programlama_Bir klasör içinden dosya isimlerini listeye almak

[NBATMAN]

Merhaba arkadaşlar;

Seçilen klasörün içindeki dosyalar liste2 de listelenir. Listelenen dosyalar ilgili buton ile Sayfa1 A sütununa aktarılarak listelenir. İlgili buton ile A sütununda adı bulunan dosyalar için kendi adları ile birlikte yeni sayfalar çalışma kitabına eklenir. Geliştirmeye açık bir konu, Userform ile kullanmak işin görselliğini arttırmak amaçlı idi. Fakat bunu makro şeklinde kullanabilirsiniz. Dolayısı ile projelerinzde faydalı olabileceğini düşündüğümden bunu eklemek istedim. İyi akşamlar...Kodlar aşağıdadır. İlgili Dosyayı indireceğiniz linkte aşağıdadır...


Klaösrdeki dosyaları listeyerek adları ile excel sheetleri ekleme - Excel Forum
Option Explicit
Const deg = "C:\deneme"
Private Sub CommandButton1_Click()
On Error Resume Next
ListBox1.Clear
ListBox2.Clear
Set ObjFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasör seçin !", &H100)
MyPath = ObjFolder.Items.Item.Path
Set kodad = ThisWorkbook.VBProject.VBComponents("Userform1").CodeModule
kodad.deleteLines 1
kodad.insertLines 1, "Const deg =" & """" & MyPath & """"
TextBox1 = MyPath
For Each klasor In CreateObject("Scripting.FileSystemObject").GetFolder(TextBox1).SubFolders
ListBox1.AddItem klasor.Name
Next
End Sub
Private Sub Label4_Click()
On Error Resume Next
ActiveWorkbook.FollowHyperlink Address:="Excel, Makro, VBA, Kod, Access Soru ve Cevap Forumu", NewWindow:=True
End Sub
Private Sub Label4_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Label4.Font.Underline = True
Label4.ForeColor = vbBlue
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
On Error Resume Next
ListBox2.Clear
For Each dosya In CreateObject("Scripting.FileSystemObject").GetFolder(TextBox1 & "\" & ListBox1).Files
ListBox2.AddItem dosya.Name
Next
End Sub
Private Sub ListBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
OpenFile
Unload Me
End Sub
Private Sub UserForm_Initialize()
On Error Resume Next
TextBox1 = deg
For Each klasor In CreateObject("Scripting.FileSystemObject").GetFolder(TextBox1).SubFolders
ListBox1.AddItem klasor.Name
Next
CommandButton1.SetFocus
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Label4.Font.Underline = False
Label4.ForeColor = &HC0&
End Sub