Klasör Listele Yazdır

[askm]

Hayırlı akşamlar.
Aşağıdaki kodlar ile klasör içerisindeki dosyaları listeliyorum. İkinci kod ile de toplu print alıyorum. 3. Kod ile de yazdırılanları farklı bir klasöre taşıyorum.
İstediğim bu 3 kodu birleştirmek Ama listeden sıralı yazdırmak ve C sutununa yazıdırldı demesi.
Yardım edeceklere şimdiden teşekkürler.
1. KOD
Sub dosyalar59()
Dim dosya As String, yol As String, sat As Long
yol = CreateObject("wscript.shell").specialfolders(10)
dosya = Dir(yol & "\sonuc\*.*")
sat = 1
Range("A:A").ClearContents
Do While dosya <> ""
Cells(sat, "A").Value = dosya
sat = sat + 1
dosya = Dir
Loop
MsgBox "Dosyalar A sütununa aktarıldı." & vbLf & "evrengizlen@hotmail.com", vbOKOnly _
+ vbInformation, Application.UserName
End Sub

2.KOD
Sub TopluYaz()
Dim evn As Object, klasor As Object, dosya As Object, yol As Variant
Set evn = CreateObject("shell.application")
Dim yol1 As String
Dim Klasorum As Object
Klasörüm = "ÇIKACAKLAR"
yol1 = ActiveWorkbook.Path & "\" & Klasörüm

yol = CreateObject("Scripting.filesystemObject").GetAbsolutePathName(yol1)
Set klasor = evn.Namespace(yol)
Set dosya = klasor.Items()
For Each dosya In dosya
dosya.InvokeVerbEx "Print"
Next
Call Dosya_Taşı
Set dosya = Nothing: Set klasor = Nothing
Set yol = Nothing: Set evn = Nothing
End Sub

3.KOD
Sub Dosya_Taşı()
Dim Dosya_Sistemi As Object, Taşı As Variant
Dim Say As Integer, Uzantı As String
Dim dosya, Klasör_Yolu_1 As String, Klasör_Yolu_2 As String

Klasör_Yolu_1 = ActiveWorkbook.Path & "\" & "ÇIKACAKLAR" & "\"
Klasör_Yolu_2 = ActiveWorkbook.Path & "\" & "ÇIKTI ALINANLAR" & "\"

Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")

For Each dosya In Dosya_Sistemi.GetFolder(Klasör_Yolu_1).Files
Uzantı = Split(dosya.Name, ".")(1)
If UCase(Uzantı) = "PDF" Or UCase(Uzantı) = "JPG" Or UCase(Uzantı) = "JPEG" Then
Say = Say + 1
Taşı = Dosya_Sistemi.MoveFile(dosya, Klasör_Yolu_2)
If Say = 500 Then GoTo son
End If
Next

son:
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[askm]

Konu günceldir.