sayfadan sayfaya koşullu aktarma

[tamer060]

İyi akşamlar arkadaşlar bir konu hakkında çözüm lazım. koşullu ve şartlı aktarma var sayfalar arası dosya ek'te açıklama olarak yazdım yardımlarınızı bekliyorum.
Teşekkürler

 

[Ömer BARAN]

Merhaba.
Aşağıdaki kod blokunu boş bir Modüle yapıştırın ve sayfadaki düğme ile bu kodu ilişkilendirin.

Sub AKTAR_EKLE()
Set g = Sheets("GÜNLÜK ADET"): Set a = Sheets("AYLIK ADET")
If WorksheetFunction.CountIf(a.Range("1:1"), g.[C1]) = 0 Then
    Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
    asut = a.Cells(1, Columns.Count).End(xlToLeft).Column + 4
    a.Cells(1, asut) = g.[C1]: a.Cells(1, asut).NumberFormat = "dd/mm/yyyy"
    a.Range(a.Cells(1, asut), a.Cells(1, asut + 3)).Merge
    a.Cells(2, asut) = g.[F2]: a.Cells(2, asut + 1) = g.[U2]
    a.Cells(2, asut + 2) = g.[W2]: a.Cells(2, asut + 3) = g.[Y2]
 
    For gsat = 3 To g.Cells(Rows.Count, 1).End(3).Row
        Set k = a.[A:A].Find(g.Cells(gsat, 1))
        If Not k Is Nothing Then
            asat = k.Row
        Else
            asat = a.Cells(Rows.Count, 1).End(3).Row + 1
            a.Cells(asat, 1) = g.Cells(gsat, 1)
            a.Cells(asat, 2) = g.Cells(gsat, 2)
        End If
            a.Cells(asat, asut) = g.Cells(gsat, 6).Value
            a.Cells(asat, asut + 1) = g.Cells(gsat, 21).Value
            a.Cells(asat, asut + 2) = g.Cells(gsat, 23).Value
            a.Cells(asat, asut + 3) = g.Cells(gsat, 25).Value
    Next
    a.Range(a.Cells(1, asut - 4), a.Cells(3, asut - 1)).Copy
    a.Range(a.Cells(1, asut), a.Cells(3, asut + 3)).PasteSpecial Paste:=xlPasteFormats
 
    ason = a.Cells(Rows.Count, 1).End(3).Row
    a.Range(a.Cells(3, asut), a.Cells(3, asut + 3)).Copy
    a.Range(a.Cells(4, asut), a.Cells(ason, asut + 3)).PasteSpecial Paste:=xlPasteFormats
    Application.CutCopyMode = False

    Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
    a.Activate: a.[A2].Activate
    MsgBox Format(g.[C1], "dd.mm.yyyy") & " tarihine ait veriler aktarıldı...", vbInformation, "..:: Ömer BARAN ::.."
Else
    MsgBox Format(g.[C1], "dd.mm.yyyy") & " tarihine ait bilgiler AYLIK ADET sayfasında zaten var!" _
            & vbLf & "Herhangi bir veri aktarımı yapılmadı!", vbCritical, "..:: Ömer BARAN ::.."
End If
End Sub

 

[tamer060]

Çok güzel olmuş hocam elinize sağlık

 

[Ömer BARAN]

.
Kolay gelsin, iyi çalışmalar dilerim.
.