Birçok dosyanın aynı hücresinden açık yada kapalı dosyaya veri yazdırma

[dsaffethoscan]

Merhaba,
Orion1'in polis53 için yazdığı kodlar benimkine benziyor ama ben uyarlayamadım.
Matbaada her iş için Excel'de bir üretim formu hazırlıyorum. Bu formu hala daha geliştirmeye çalışıyorum. Boş şablon ektedir. Ayrıca üretimde neler olduğunu ve ne aşamalarının olduğunu görmek için de İş Takip Listemiz var. Ekte gönderiyorum. Yapmak istediğim ise Fiş No-Firma Adı-İşin Adı-Baskı Makinesi-Fiş Tarihi-Teslimat Tarihi bilgilerinin İş Takip Listesine yazılması ile Selofan-Gofre-Varak-Lak-Kesim-Sıvama-Yapıştırma-Cilt gibi özelliklerinin İş Takip Listesine nerede yapılıyorsa yapılan yerin adının yazılması. Bu özelliklerde "yok" seçili ise hiçbirşey yazılmamasını istiyorum. 3 adet rastgele yazdığım fişi de gönderiyorum. İş Takip Listesinin hücrelerine "='D:\Formlar\Uretim_Form\[8001.xls]Üretim Formu'!$G$9" vs. şeklinde yazdırıyorum. Ama her fiş için [8001.xls] dosya adını 1 arttırmak zorunda kalıyorum. Bunu manuel yapmak çok vaktimi alıyor. Makro ile yazdırmaya çalıştım ama bir türlü beceremedim.

 

[dsaffethoscan]

Sanırım benim konuma cevap verebilecek kimse yok veya kimsenin ilgisini çekmiyor.
Araştırmalarım sonunda aşağıdaki gibi bir kod buldum.

Sub TÜM_VERİLERİ_AL()
    Dim Is_Takip_Listesi As Workbook, Dosya As Object, Kaynak_Dosya As Workbook
    Dim Is_Takip_Listesi_Yolu As String, Satır As Long
    
    On Error GoTo Son
    
    Application.ScreenUpdating = False
    
    Set Is_Takip_Listesi = ThisWorkbook
    
    Is_Takip_Listesi_Yolu = Is_Takip_Listesi.Path
    
    If CreateObject("Scripting.FileSystemObject").GetFolder(Is_Takip_Listesi_Yolu).Files.Count = 0 Then GoTo Son
    
    Is_Takip_Listesi.Sheets("Sayfa1").Range("A2:O65536").ClearContents
    
    Satır = Is_Takip_Listesi.Sheets("Sayfa1").Range("A65536").End(3).Row + 1
    
    For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Is_Takip_Listesi_Yolu).Files
        
        If Dosya <> Is_Takip_Listesi_Yolu & "\Is_Takip_Listesi.xls" Then
        
        Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
    
        Is_Takip_Listesi.Sheets("Sayfa1").Cells(Satır, 1) = Replace(Kaynak_Dosya.Name, ".xls", "")
        Is_Takip_Listesi.Sheets("Sayfa1").Cells(Satır, 2) = [G7]
        Is_Takip_Listesi.Sheets("Sayfa1").Cells(Satır, 3) = [G9]
        Is_Takip_Listesi.Sheets("Basıldığı Yer ve Makine").Cells(Satır, 5) = [C3]
        Is_Takip_Listesi.Sheets("Sayfa1").Cells(Satır, 6) = [G2]
        Is_Takip_Listesi.Sheets("Sayfa1").Cells(Satır, 7) = [V2]
        Is_Takip_Listesi.Sheets("Laminasyonlar").Cells(Satır, 8) = [B4]
        Is_Takip_Listesi.Sheets("Laminasyonlar").Cells(Satır, 9) = [B11]
        Is_Takip_Listesi.Sheets("Laminasyonlar").Cells(Satır, 10) = [B15]
        Is_Takip_Listesi.Sheets("Laminasyonlar").Cells(Satır, 11) = [B19]
        Is_Takip_Listesi.Sheets("Laminasyonlar").Cells(Satır, 12) = [B23]
        Is_Takip_Listesi.Sheets("Laminasyonlar").Cells(Satır, 13) = [B27]
        Is_Takip_Listesi.Sheets("Laminasyonlar").Cells(Satır, 14) = [B31]
        Is_Takip_Listesi.Sheets("Laminasyonlar").Cells(Satır, 15) = [B35]
        Satır = Satır + 1
        
        Kaynak_Dosya.Close True
        
        End If

Bu kodu 3 satır olarak bulmuştum. Benim dosyama göre çoğalttım. Ama kodu:

Is_Takip_Listesi.Sheets("Sayfa1").Cells(Satır, 1) = Replace(Kaynak_Dosya.Name, ".xls", "")
Is_Takip_Listesi.Sheets("Sayfa1").Cells(Satır, 2) = [G7]
Is_Takip_Listesi.Sheets("Sayfa1").Cells(Satır, 3) = [G9]

satırları ile yazarsam çalışıyor. Bana diğer satırlar da lazım. Yeni yazılmış kodlarla Is_Takip_Listesi dosyasını tekrar yüklüyorum. Bir de bu kodlarla daha önce dolu olan satırları da silip tekrar dosyaların hepsini açıp veri alıyor. Dolu olan satırların dosyasını açmasın (hatta olabilirse makroyu çalıştırınca dosyaları açmadan verileri alsın.)

 

[dsaffethoscan]

Sorunumu çözdüm. Bilmek isteyenler için kodlar şöyle;

Sub Guncelle()
Dim con As Object, dosya As Object, evn As Object
Dim klas As Object, rs As Object, yol As String, son As Long
Set con = CreateObject("adodb.connection")
Set evn = CreateObject("scripting.filesystemobject")
Set rs = CreateObject("adodb.recordset")
yol = ThisWorkbook.Path
Set klas = evn.getfolder(yol)
For Each dosya In klas.Files
If dosya.Name <> "Is_Takip_Listesi.xls" And _
        dosya.Name <> "Uretim_Formu_Sablon.xls" And _
        LCase(Right(dosya.Name, 3)) = "xls" Then
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & dosya.Path & ";extended properties=""excel 12.0;hdr=yes"""
    rs.Open "select top 1 * from [ozet$]", con, 1, 1
    son = IIf(Range("c65536").End(3)(2, 1).Row = 3, 4, Range("c65536").End(3)(2, 1).Row)
    Range("c" & son).CopyFromRecordset rs
    rs.Close
    con.Close
End If
Next dosya
son = Empty
Set con = Nothing: Set rs = Nothing
Set evn = Nothing: Set klas = Nothing
Set dosya = Nothing: yol = vbNullString
End Sub

excell 2010 kullanıyorum. Ama işyerinde birkaç bilgisayarda 2003 olduğu için xls olarak kaydediyorum.