- Katılım
- 4 Haziran 2005
- Mesajlar
- 2,745
- Excel Vers. ve Dili
- 2010-2016
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
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