Kapalı Dosyaya Veri Aktarma (Kurallı)

[leonadies]

Üstadlar Merhaba;

Sitede araştırma yaptım ancak konularda verilen linklerin ölmesi nedeniyle sağlıklı bilgilere ulaşamadım. Yolun başında biri olarak aşağıdaki kodlarıma (??? işaretli yerlere) yardım rica ediyorum.

Amacım:
bu kitabın "giriş" sekmesindeki A:F aralığını
\\server\siparisler\kayıtlar\datalar.xlsm dosyası YEDEK sekmesinde A sutunu son dolu hücreyi bularak kopyalaması

Sub disaaktar2()

Application.ScreenUpdating = False
   
    yol = "\\server\siparisler\kayıtlar\"            
    hedef = "datalar.xlsm" ??????                      ' datalar excelinin "yedek" sekmesi
    kaynak= ??????????                                     ' Bu kitabın "giris" sekmesi diyeceğiz
    son= ???????????                                        ' Hedef kitaptaki son dolu hücre HEDEF
   
    Workbooks.Open (yol & hedef)                      'hedef dosyayı aç
    ???????????????????????????????????????????       'Kaynak dosyanın A:F sütununu kopyalamak. Bunu yparken Hedef in A sutunundaki son dolu hücresini bularak yapıştırması

Workbooks(hedef).Save
Workbooks(hedef).Close
Application.ScreenUpdating = True
End Sub

 

[leonadies]

yardım edebilir misiniz?

 

[leonadies]

güncel

 

[Korhan Ayhan]

Ham aktarım kodu olarak aşağıdaki yapıyı kullanabilirsiniz.

Belki aralara kontroller için koşul satırları eklenmesi gerekebilir.

Option Explicit

Sub Verileri_Aktar()
    Dim Kaynak_Kitap As Workbook, Kaynak_Sayfa As Worksheet
    Dim Hedef_Kitap As Workbook, Hedef_Sayfa As Worksheet
    Dim Yol As String, Dosya_Adi As String
    Dim Kaynak_Son_Satir As Long, Hedef_Son_Satir As Long
    
    Application.ScreenUpdating = False
   
    Set Kaynak_Kitap = ThisWorkbook
    Set Kaynak_Sayfa = Kaynak_Kitap.Sheets("Giriş")
    
    Kaynak_Son_Satir = Kaynak_Sayfa.Cells(Kaynak_Sayfa.Rows.Count, 1).End(3).Row + 1
    
    Yol = "\\server\siparisler\kayıtlar\"
    Dosya_Adi = "datalar.xlsm"
   
    Set Hedef_Kitap = Workbooks.Open(Yol & Dosya_Adi, False, False)
    Set Hedef_Sayfa = Hedef_Kitap.Sheets("Yedek")
    
    Hedef_Son_Satir = Hedef_Sayfa.Cells(Hedef_Sayfa.Rows.Count, 1).End(3).Row + 1
    
    Kaynak_Sayfa.Range("A1:F" & Kaynak_Son_Satir).Copy Hedef_Sayfa.Range("A" & Hedef_Son_Satir)

    Hedef_Kitap.Close True
    
    Application.ScreenUpdating = True
    
    MsgBox "Veri aktarımı tamamlanmıştır.", vbInformation
End Sub

 

[leonadies]

Korhan Hocam bende bu dosya üzerinde çalışıyordum. Ağ üzerindeki halinden ziyade bir deneme dosya ile işi çözmeye çalıştım. bir kısma kadar getirdim ancak şu an önümde 1 sorun kaldı.
Kapalı excele kaydı yaparken fiş numarasına bakarak üst kısımlarda mükerrrer kayıtları sildirmek. (yalnız satır bazında değil A: D hücre aralığı şeklinde sildirmek). Amacım güncel olan son hali hep alta kalsın. Dosyalarımı ve kodumu ekledim.

Sub Aktar()

Application.ScreenUpdating = False

yol = "D:\Deneme\"
hedef = "kapalı.xlsm"

Workbooks.Open (yol & hedef)
Workbooks("açık.xlsm").Sheets("Sayfa1").Range("A1:D10000").Copy Range("A65536").End(xlUp)

ActiveWorkbook.Save
ActiveWorkbook.Close

MsgBox "Aktarıldı"
End Sub

 

[leonadies]

Korhan hocam teşekürler. Sorunsuz çalışıyor. Birde kayıt yaptığı yerde mükerrer üst kayıtları sildirebilsek süper olacak. A sütunu fiş numaralrını içeriyor. Bunu referans alabilir makromuz.

 

[Korhan Ayhan]

İnceleyiniz.

 

[leonadies]

Ellerinize Sağlık. Süper olmuş
Sadece 2 noktada sorun cıkıyor. Bunlar;
--2. Satırda bir değişiklik olursa Kapalı excelde bunu direk siliyor.
--Açık excelin satır dizilimleri arasında "boş satır kalırsa" yada "Satır Komple silinirse" makro hata veriyor

 

[Korhan Ayhan]

Üstteki mesajımda ki dosyaları revize ettim. Tekrar deneyiniz.

 

[leonadies]

Teşekkürler Korhan Hocam

 

[NullHero]

Korhan bey selamlar. Kodlar için öncelikle teşekkürler.
Kapalı dosyada, sürekli sıradaki ilk satırdan itibaren yazmasını nasıl sağlayabilirim ? Örneğin; hazırlamış olduğunuz "AÇIK" isimli çalışmada "AKTAR" tuşuna 2. kez basıldığında, aktarılması gereken veri, ilk basımda aktarılan veriden sonraki hücreden itibaren yazdırılır mı?
Amacım, birden fazla "AÇIK" (Açık1,Açık2,...)isimli dosyadan, "KAPALI" isimli dosyaya sürekli veri aktarmak.

 

[Korhan Ayhan]

Merhaba,

Deneyiniz.

Option Explicit

Sub Verileri_Aktar()
    Dim Zaman As Double, Yol As String, Dosya_Adi As String
    Dim Kaynak_Kitap As Workbook, Kaynak_Sayfa As Worksheet, Kaynak_Son_Satir As Long
    Dim Hedef_Kitap As Workbook, Hedef_Sayfa As Worksheet, Hedef_Son_Satir As Long
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
   
    Set Kaynak_Kitap = ThisWorkbook
    Set Kaynak_Sayfa = Kaynak_Kitap.Sheets("Sayfa1")
    
    Kaynak_Son_Satir = Kaynak_Sayfa.Cells(Kaynak_Sayfa.Rows.Count, 1).End(3).Row + 1
    
    Yol = ThisWorkbook.Path & "\"
    Dosya_Adi = "Kapalı.xlsm"
   
    Set Hedef_Kitap = Workbooks.Open(Yol & Dosya_Adi, False, False)
    Set Hedef_Sayfa = Hedef_Kitap.Sheets("Sayfa1")
    
    If Hedef_Sayfa.Range("A1") = "" Then
        With Hedef_Sayfa.Range("A1:D1")
            .Value = Array("Fiş No", "Durum", "Tarih", "Açıklama")
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
        End With
    End If
    
    Hedef_Son_Satir = Hedef_Sayfa.Cells(Hedef_Sayfa.Rows.Count, 1).End(3).Row + 1
    
    Kaynak_Sayfa.Range("A2:D" & Kaynak_Son_Satir).Copy Hedef_Sayfa.Range("A" & Hedef_Son_Satir)

    Hedef_Sayfa.Columns.AutoFit
    Hedef_Kitap.Close True
    
    Application.ScreenUpdating = True
    
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[NullHero]

Korhan bey,
Elinize sağlık, teşekkür ederim.
Bu işlem, A2: D2 ve aşağısına doğru veri var ise, aktarma yapıyor. Peki, Hücre aralığı yerine, sayfada farklı yerlerde bulunan önceden belirlenmiş hücreleri ("M20", "T10", "M6", "T9" gibi), Kapalı sayfaya aktardığımız formatta (sırasıyla A2-B2-C2,D2) şeklinde yapılabilir mi ?

Mesaj #4 te bahsetmiş olduğunuz "Belki aralara kontroller için koşul satırları eklenmesi gerekebilir." ile ilgili,
Aktarım yapılması istenen hücrelerden bir tanesi bile boş ise, aktarım yapılamaz - ya da hücre boş - , gibi bir uyarı mesajı verebilir miyiz ?
Özetle, yazmış olduğunuz bu kod sayesinde, "Sterilizasyon için Gamma 'ya gidecek malzemelerin detaylarını, Sterilizasyon Listesine çekmiş olacağım, hatasız bir şekilde (Bunun için tekrar teşekkür ederim). Ama bu 4 hücreden biri boş olursa (Kullanıcı dalgınlığı-dikkatsizliği sonucu), felaketle sonuçlanabilecek bir durum yaratabilir.

Haberlerinizi beklerim.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Verileri_Aktar()
    Dim Zaman As Double, Yol As String, Dosya_Adi As String
    Dim Kaynak_Kitap As Workbook, Kaynak_Sayfa As Worksheet
    Dim Hedef_Kitap As Workbook, Hedef_Sayfa As Worksheet, Hedef_Son_Satir As Long
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
   
    Set Kaynak_Kitap = ThisWorkbook
    Set Kaynak_Sayfa = Kaynak_Kitap.Sheets("Sayfa1")
    
    Yol = ThisWorkbook.Path & "\"
    Dosya_Adi = "Kapalı.xlsm"
   
    Set Hedef_Kitap = Workbooks.Open(Yol & Dosya_Adi, False, False)
    Set Hedef_Sayfa = Hedef_Kitap.Sheets("Sayfa1")
    
    If Hedef_Sayfa.Range("A1") = "" Then
        With Hedef_Sayfa.Range("A1:D1")
            .Value = Array("Fiş No", "Durum", "Tarih", "Açıklama")
            .Font.Bold = True
            .HorizontalAlignment = xlCenter
        End With
    End If
    
    Hedef_Son_Satir = Hedef_Sayfa.Cells(Hedef_Sayfa.Rows.Count, 1).End(3).Row + 1
    
    Kaynak_Sayfa.Range("M20").Copy Hedef_Sayfa.Range("A" & Hedef_Son_Satir)
    Kaynak_Sayfa.Range("T10").Copy Hedef_Sayfa.Range("B" & Hedef_Son_Satir)
    Kaynak_Sayfa.Range("M6").Copy Hedef_Sayfa.Range("C" & Hedef_Son_Satir)
    Kaynak_Sayfa.Range("T9").Copy Hedef_Sayfa.Range("D" & Hedef_Son_Satir)

    Hedef_Sayfa.Columns.AutoFit
    Hedef_Kitap.Close True
    
    Application.ScreenUpdating = True
    
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[NullHero]

Korhan bey,
Çok teşekkürler.

"Boş ise hata ver, tarih formatında değilse hata ver" şeklindeki sorgularımı, aşağıdaki kodların hemen üstünde gerçekleştirmem gerekiyor, değil mi ?

Kaynak_Sayfa.Range("M20").Copy Hedef_Sayfa.Range("A" & Hedef_Son_Satir)
Kaynak_Sayfa.Range("T10").Copy Hedef_Sayfa.Range("B" & Hedef_Son_Satir)
Kaynak_Sayfa.Range("M6").Copy Hedef_Sayfa.Range("C" & Hedef_Son_Satir)
Kaynak_Sayfa.Range("T9").Copy Hedef_Sayfa.Range("D" & Hedef_Son_Satir)

 

[Korhan Ayhan]

Evet..

 

[NullHero]

Korhan bey,
Aşağıdaki gibi yağtığımda hata alabiliyorum lakin, Aktarma yaptığımız kapalı dosya, "Hata Mesajı" 'ndan sonra açılıyor.
Bunun için, Exit Sub öncesinde " Hedef_Kitap.Close True " yazdığımda ise açılmıyor fakat, macro işlem yapıyormuş gibi hücreleri gözükmeden açılıyor ve hata mesajına tamam dedikten sonra kapanıyor. Kısacası macrodan çıkışı yazamadım sanırım.
Yapmaya çalıştığım, bahse konu "4" hücrenin boş olması durumunda macronun çalışmaması.


Hedef_Son_Satir = Hedef_Sayfa.Cells(Hedef_Sayfa.Rows.Count, 1).End(3).Row + 1

If Kaynak_Sayfa.Range("M20") = "" Or Kaynak_Sayfa.Range("T10") = "" Or Kaynak_Sayfa.Range("M6") = "" Or Kaynak_Sayfa.Range("T9") = "" Then

MsgBox "M20, T10, M6 ve T9 Hücreleri Boş Olamaz."

Exit Sub

Else

Kaynak_Sayfa.Range("M20").Copy Hedef_Sayfa.Range("A" & Hedef_Son_Satir)
Kaynak_Sayfa.Range("T10").Copy Hedef_Sayfa.Range("B" & Hedef_Son_Satir)
Kaynak_Sayfa.Range("M6").Copy Hedef_Sayfa.Range("C" & Hedef_Son_Satir)
Kaynak_Sayfa.Range("T9").Copy Hedef_Sayfa.Range("D" & Hedef_Son_Satir)

 

[Korhan Ayhan]

Siz koşullarınızı "Yol" ile başlayan satırın üstüne yazıp deneyiniz.

 

[NullHero]

Teşekkürler. (Bu tebessüm tüm katta yankılanmış olabilir)
Peki, Bu 4 değerin, kopyalandığı sayfadaki bir önceki 4 değer ile aynı olma koşulunda, nasıl ilerlemem gerekir ? aynı bilgilerin 2. kez yazılmaması/aktarılmaması.

 

[Korhan Ayhan]

Normalde #7 nolu mesajımdaki örnek dosyalarda bu kontrol yapılıyor.

Bir önceki satırdaki verilerle kontrolü yeterli ise aşağıdaki gibi yapabilirsiniz.

    If Kaynak_Sayfa.Range("M20") = Hedef_Sayfa.Range("A" & Hedef_Son_Satir - 1) And _
       Kaynak_Sayfa.Range("T10") = Hedef_Sayfa.Range("B" & Hedef_Son_Satir - 1) And _
       Kaynak_Sayfa.Range("M6") = Hedef_Sayfa.Range("C" & Hedef_Son_Satir - 1) And _
       Kaynak_Sayfa.Range("M6") = Hedef_Sayfa.Range("D" & Hedef_Son_Satir - 1) Then
       MsgBox "Mükerrer kayıt yapılamaz!", VbCritical
       Hedef_Kitap.Close False
       Exit Sub
    End If

    Kaynak_Sayfa.Range("M20").Copy Hedef_Sayfa.Range("A" & Hedef_Son_Satir)
    Kaynak_Sayfa.Range("T10").Copy Hedef_Sayfa.Range("B" & Hedef_Son_Satir)
    Kaynak_Sayfa.Range("M6").Copy Hedef_Sayfa.Range("C" & Hedef_Son_Satir)
    Kaynak_Sayfa.Range("T9").Copy Hedef_Sayfa.Range("D" & Hedef_Son_Satir)