Bağ Yapıştır'da kaynak hücre biçimiyle nasıl aktarılır.

[Yavuzdan]

Selam,

Bir süredir arıyorum ama çözüm bulamadım,

Sürekli güncellenen Farklı bir excel kitabı "Siparis" sayfasından A3:U2500 hücrelerini güncel olarak başka bir excel kitabına, aynı karsilik gelen A3:U2500 hücrelerine Bağ oluşturuyorum.

Kaynak hücreler sürekli içeriği değiştikce renk değiştiriyor. Fakat Bağ oluşturduğum Hedef hücrelerde sadece değerler değişiyor. Renkler hedefe taşınmıyor, renkler ve hücre biçimleri değişmiyor.

Bu sorunu nasıl çözeceğimi bulamadım, ustalarımın yönlendirmesine ihtiyacım var.

Teşekkürler...

 

[Yavuzdan]

Sanırım bu takıldığım konu, çok zor bir konu...

Eğer sorunumu ben yeteri kadar açık anlatamadımsa bir örnek dosya ekliyorum.

Lütfen konu hakkında görüşü olan bir arkadaşımız yanıtlarsa çok memnun olurum...

Teşekkürler...

 

[Yavuzdan]

Bu konuda bılgısı olan yokmu??

Başka çalışma kitabından makro ile hücreleri biçimleriyle kopyalamak da iş görür.

 

[Korhan Ayhan]

Selamlar,

Bu işlemi ancak iki dosya açıkken kopyala-yapıştır yöntemi ile yapabilirsiniz. Aşağıdaki kodu kullanabilirsiniz.

Kodun doğru çalışması için iki kitabında açık olması gereklidir.

Option Explicit
 
Sub BİÇİMLE_BERABER_AKTAR()
    Dim K1 As Workbook, K2 As Workbook
    
    Set K1 = ThisWorkbook
    Set K2 = Workbooks("Kitap2")
    
    Application.ScreenUpdating = False
    K1.Sheets("Sipariş").Range("A3:U2500").Copy
    K2.Activate
    Sheets("Sayfa1").Select
    Range("A3").Select
    ActiveSheet.Paste Link:=True
    Range("A3").PasteSpecial Paste:=xlPasteFormats
    Range("A3").Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
    Set K1 = Nothing
    Set K2 = Nothing
    
    MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
End Sub

 

[Yavuzdan]

Selamlar,

Bu işlemi ancak iki dosya açıkken kopyala-yapıştır yöntemi ile yapabilirsiniz. Aşağıdaki kodu kullanabilirsiniz.

Kodun doğru çalışması için iki kitabında açık olması gereklidir.

Option Explicit
 
Sub BİÇİMLE_BERABER_AKTAR()
    Dim K1 As Workbook, K2 As Workbook
    
    Set K1 = ThisWorkbook
    Set K2 = Workbooks("Kitap2")
    
    Application.ScreenUpdating = False
    K1.Sheets("Sipariş").Range("A3:U2500").Copy
    K2.Activate
    Sheets("Sayfa1").Select
    Range("A3").Select
    ActiveSheet.Paste Link:=True
    Range("A3").PasteSpecial Paste:=xlPasteFormats
    Range("A3").Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
    Set K1 = Nothing
    Set K2 = Nothing
    
    MsgBox "Aktarım işlemi tamamlanmıştır.", vbInformation
End Sub

Hocam merhaba,

ilginiz için çok teşekkür ederim, ama hazırladığınız kod pek işimi görmüyor. Kaynak dosyaya erişim sadece READ ONLY olacagindan iki dosyanında açık olması mümkün olmayacak.

Ben kısmen uzun uğraşlar sonucunda aşağıdaki kod ile işi baya bi çözdüm fakat, sadece kaynak dosyadaki değerler ve renkler değil Formüllerde hedef dosyaya taşındı.

Aşağıda örneğini verdiğim kod da 2 farklı yol denedim ama ya sadece değerler geliyor yada formüller dahil tüm biçimler. Formülleri arada çıkaramadım.

Kod da nasıl bir düzenleme yapmam gerektiği konusunda yardımlarınızı rica ediyorum hocam..

Kod:

Sub VERİLERİ_AKTAR()
Dim Dosya_Yolu As String, Asıl_Dosya As Workbook, Kaynak_Dosya As Workbook
Application.ScreenUpdating = False
Set Asıl_Dosya = ThisWorkbook
Asıl_Dosya.ActiveSheet.[A3:U2500].ClearContents
Dosya_Yolu = ThisWorkbook.Path & "\"
Set Kaynak_Dosya = Workbooks.Open(Dosya_Yolu & "GUNCEL_SIPARIS.xls", False, False)
Kaynak_Dosya.Sheets("SIPARIS").Range("A3:U2500").Copy
Asıl_Dosya.Activate

'Range("A3:U2500").PasteSpecial (xlPasteValuesAndNumberFormats) '(SADECE DEĞERLERİ GETİRİYOR AMA RENK YOK)
Range("A3:U2500").Select ' DEĞERLERİ, RENKLERİ VE FORMÜLLERİ GETİRİYOR
ActiveSheet.Paste
' DEĞERLERİ , RENKLERİ GETİRSİN AMA FORMÜLLERİ GETİRMESİN

Application.CutCopyMode = False
Range("A3:U2500").Select
Kaynak_Dosya.Close True
Set Kaynak_Dosya = Nothing
Set Asıl_Dosya = Nothing
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Korhan Ayhan]

Selamlar,

Vermiş olduğunuz kodlarda benim daha önce başka bir başlıkta kullandığım kodlardır. Bir önceki mesajımda önerdiğim kod ile aralarında çok büyük bir farklılık yok. Eğer bu kod işinizi görüyorsa aşağıdaki şekilde değiştirip kullanabilirsiniz.

Option Explicit
 
Sub VERİLERİ_AKTAR()
    Dim Dosya_Yolu As String, Asıl_Dosya As Workbook, Kaynak_Dosya As Workbook
    
    Application.ScreenUpdating = False
        Set Asıl_Dosya = ThisWorkbook
        Asıl_Dosya.ActiveSheet.Range("A3:U2500").ClearContents
        Dosya_Yolu = ThisWorkbook.Path & "\"
        Set Kaynak_Dosya = Workbooks.Open(Dosya_Yolu & "GUNCEL_SIPARIS.xls", False, False)
        Kaynak_Dosya.Sheets("SIPARIS").Range("A3:U2500").Copy
        Asıl_Dosya.Activate
[COLOR=red]        Range("A3").PasteSpecial Paste:=xlPasteValues
        Range("A3").PasteSpecial Paste:=xlPasteFormats
[/COLOR]        Application.CutCopyMode = False
        Kaynak_Dosya.Close True
        Set Kaynak_Dosya = Nothing
        Set Asıl_Dosya = Nothing
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Yavuzdan]

Selamlar,

Vermiş olduğunuz kodlarda benim daha önce başka bir başlıkta kullandığım kodlardır. Bir önceki mesajımda önerdiğim kod ile aralarında çok büyük bir farklılık yok. Eğer bu kod işinizi görüyorsa aşağıdaki şekilde değiştirip kullanabilirsiniz.

Option Explicit
 
Sub VERİLERİ_AKTAR()
    Dim Dosya_Yolu As String, Asıl_Dosya As Workbook, Kaynak_Dosya As Workbook
    
    Application.ScreenUpdating = False
        Set Asıl_Dosya = ThisWorkbook
        Asıl_Dosya.ActiveSheet.Range("A3:U2500").ClearContents
        Dosya_Yolu = ThisWorkbook.Path & "\"
        Set Kaynak_Dosya = Workbooks.Open(Dosya_Yolu & "GUNCEL_SIPARIS.xls", False, False)
        Kaynak_Dosya.Sheets("SIPARIS").Range("A3:U2500").Copy
        Asıl_Dosya.Activate
[COLOR=red]        Range("A3").PasteSpecial Paste:=xlPasteValues
        Range("A3").PasteSpecial Paste:=xlPasteFormats
[/COLOR]        Application.CutCopyMode = False
        Kaynak_Dosya.Close True
        Set Kaynak_Dosya = Nothing
        Set Asıl_Dosya = Nothing
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Selamlar Hocam,

Bu sorunumu çözebilmek için baya bi forum konularında gezdim. Sizin, Evren ve Ömer hocalarımın birçok çalışmanızı inceledim.İşime yarar kodları toplayarak harmanladım ve en son bu kod dizisi sayesinde işimi nihayet gördüm.

Yardımlarınız için çok teşekkür ederim. Gayet güzel bir çalışma çıktı ortaya, Emeğinize sağlık.

ihtiyacı olan başka arkadaşlara yardımcı olabilmek için son halini aşağıda veriyorum. Umarım başkalarının da işini görür.
KOD:
Application.ScreenUpdating = False
Set Asıl_Dosya = ThisWorkbook
Asıl_Dosya.ActiveSheet.[A3:O3500].ClearContents
Set Kaynak_Dosya = Workbooks.Open("\\satissip$\SATIS_SIPARIS.xls", False, False)
Kaynak_Dosya.Sheets("SIPARIS").Range("A3:O3500").Copy
Asıl_Dosya.Activate

Range("A3:O3500").PasteSpecial Paste:=xlPasteValues 'SADECE DEĞERLERİ GETIRIYOR
Range("A3:O3500").PasteSpecial Paste:=xlPasteFormats 'SADECE FORMATLARI GETIRIYOR
Application.CutCopyMode = False
Range("A3:O3500").Select
Kaynak_Dosya.Close True
Set Kaynak_Dosya = Nothing
Application.ScreenUpdating = True

Set Kaynak_Dosya2 = Workbooks.Open("\\Belgelerim\DEPO_SIPARIS.xls", False, False)
Kaynak_Dosya2.Sheets("SIPARIS").Range("V3:AE3500").Copy
Asıl_Dosya.Activate
Range("V3:AE3500").Select ' DEĞERLERİ, RENKLERİ VE FORMÜLLERİ GETİRİYOR
ActiveSheet.Paste
Application.CutCopyMode = False
Range("V3:AE3500").Select
Kaynak_Dosya2.Close True
Set Kaynak_Dosya2 = Nothing
Set Asıl_Dosya = Nothing
Application.ScreenUpdating = True
MsgBox "Güncellemeler Tamamlanmıştır." & vbLf & _
"" & vbLf & _
" iyi çalışmalar", vbInformation
End Sub