Dosya Listeleme ve Kopyalama

[askm]

Kolay gelsin.
Daha önceden bulduğum kodlar ile klasör seçip dosyaları listeleme yapabiliyorum. bu kodu 2 kere çalıştırıp 2 farklı dosya seçiyorum. Benim istediğim Açılışta kaynak ve hedef adında iki dosya seçsin, bunların altındaki dosyaları Kaynakdakileri Sayfa1 e Hedeftekileri Sayfa2 ye kaydetsin. Sayfa1 yani Kaynak Klasörün listelendiği sayfada I sütununa dosya mevcut EVET HAYIR yazsız. J sutununa da Son Düzenleme Tarihi ve Saati Sayfa2 dekinden (Hedef Klaösrdekinden) sonra olanları Güncel yazsın. Burada sadece Dosya Mevcut kısmında yani I sütununda HAYIR yazanları ve J sütununda Güncel yazanları hedef klasör kopyala butonuna basınca kopyalasın istiyorum.
Örnek dosya ektedir. Kod çalışınca H ye kadar otomatik kendi dolduruyor. DosyaListelem1 sayfasında I ve J sütunlarını da DosyaListelem2 sayfasında listeleme yaptıktan sonra doldurması gerek.

 

[askm]

Aşağıdaki kod ile tek makro ile 2 klasörü listeleyip VAR YOK yazdırabiliyorum. Güncel olup olmadığı hakkında yardım istiyorum.

Dim msg1 As String
Dim s1, s2 As Worksheet
    
Sub dosyaListele1()

'msg1 = MsgBox("Alt klasör dahil edilsinmi.? ", vbYesNo + vbInformation, "u y a r ı !")
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 Atla1


Set klasor2 = CreateObject("shell.application").BrowseForFolder(0, "Hedef Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not klasor2 Is Nothing Then
kaynak2 = klasor2.SELF.Path
If InStr(1, kaynak2, "{") > 0 Then GoTo Atla2


Set s1 = Sheets("DosyaListeleme1")
Set s2 = Sheets("DosyaListeleme2")
s1.Select

s1.Cells.ClearContents
s1.Range("A1") = "Dosya Yolu"
s1.Range("B1") = "Dosya Adı"
s1.Range("C1") = "Dosya Tipi"
s1.Range("D1") = "Dosya Boyutu"
s1.Range("E1") = "Oluşturulma Tarihi"
s1.Range("F1") = "Son Erişim Tarihi"
s1.Range("G1") = "Son Düzenleme Tarihi"
s1.Range("H1") = "Son Düzenleme Zamanı"


s2.Cells.ClearContents
s2.Range("A1") = "Dosya Yolu"
s2.Range("B1") = "Dosya Adı"
s2.Range("C1") = "Dosya Tipi"
s2.Range("D1") = "Dosya Boyutu"
s2.Range("E1") = "Oluşturulma Tarihi"
s2.Range("F1") = "Son Erişim Tarihi"
s2.Range("G1") = "Son Düzenleme Tarihi"
s2.Range("H1") = "Son Düzenleme Zamanı"
s2.Range("I1") = "Dosya Var mı Yok Mu?"
s2.Range("J1") = "Güncel mi?"


Liste1 (kaynak)
Liste2 (kaynak2)
MsgBox "işlem tamam !", vbInformation, "DİKKAT"
Else
Atla1:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Else
Atla2:
MsgBox "Lütfen Hedef Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

Set Obj = Nothing
Set klasor = Nothing

End Sub





Private Sub Liste1(yol As String)

Dim fs As Object, f As Object, j As Long
Set fs = CreateObject("Scripting.FileSystemObject")
Set s1 = Sheets("DosyaListeleme1")
Set s2 = Sheets("DosyaListeleme2")
s1.Select

For Each Dosya In fs.GetFolder(yol).Files
'Uzanti = fs.GetExtensionName(dosya)
'If Uzanti = "xls" Or Uzanti = "xlsx" Then

j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1

s1.Cells(j, 1) = Dosya.ParentFolder 'Dosya
s1.Cells(j, 2) = Dosya.Name 'Dir(Dosya)

With fs.GetFile(Dosya)
ActiveSheet.Hyperlinks.Add Anchor:=Range("B" & j), Address:=Dosya
s1.Range("C" & j) = .Type
s1.Range("D" & j) = Format(.Size / 1024, "#,##0.0000") & " Kb"
s1.Range("E" & j) = Format(.DateCreated, "dd.mm.yyyy")
s1.Range("F" & j) = Format(.DateLastAccessed, "dd.mm.yyyy")
s1.Range("G" & j) = Format(.DateLastModified, "dd.mm.yyyy")
s1.Range("H" & j) = Format(.DateLastModified, "hh:mm:ss")
End With
'End If
Next

Set fL = Nothing

End Sub
Private Sub Liste2(yol As String)

Dim fs As Object, f As Object, j As Long
Set fs = CreateObject("Scripting.FileSystemObject")
Set s1 = Sheets("DosyaListeleme1")
Set s2 = Sheets("DosyaListeleme2")
s2.Select

For Each Dosya In fs.GetFolder(yol).Files
'Uzanti = fs.GetExtensionName(dosya)
'If Uzanti = "xls" Or Uzanti = "xlsx" Then

j = WorksheetFunction.CountA(Worksheets(ActiveSheet.Name).Range("A1:A" & Rows.Count)) + 1

s2.Cells(j, 1) = Dosya.ParentFolder 'Dosya
s2.Cells(j, 2) = Dosya.Name 'Dir(Dosya)

With fs.GetFile(Dosya)
ActiveSheet.Hyperlinks.Add Anchor:=Range("B" & j), Address:=Dosya
s2.Range("C" & j) = .Type
s2.Range("D" & j) = Format(.Size / 1024, "#,##0.0000") & " Kb"
s2.Range("E" & j) = Format(.DateCreated, "dd.mm.yyyy")
s2.Range("F" & j) = Format(.DateLastAccessed, "dd.mm.yyyy")
s2.Range("G" & j) = Format(.DateLastModified, "dd.mm.yyyy")
s2.Range("H" & j) = Format(.DateLastModified, "hh:mm:ss")
s2.Range("I" & j).FormulaR1C1 = _
        "=IF(COUNTIFS(DosyaListeleme1!C[-7],RC[-7],DosyaListeleme1!C[-2],RC[-2],DosyaListeleme1!C[-1],RC[-1])>0,""VAR"",""YOK"")"
End With
'End If
Next

Set fL = Nothing

End Sub

 

[askm]

copychangedfiles tarzı bir program yapmak istiyorum. Bu tarzda excelde yapma imkanı yok mu?