Sayfalar arası veri aktarımı

[acetinnster]

Sayfalar arası veri aktarımı ile ilgili yardımınıza ihtiyacım var

 

[YUSUF44]

Aşağıdaki makroyu deneyin:

Sub aktar()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
son = WorksheetFunction.Max(3, s1.Cells(Rows.Count, "D").End(3).Row)
veri = WorksheetFunction.Max(3, s2.Cells(Rows.Count, "A").End(3).Row)
If s1.[B1] = "" Then
    MsgBox "Lütfen önce tarih giriniz!", vbCritical
    s1.Activate
    s1.[B1].Select
ElseIf IsDate(s1.[B1]) = False Then
    MsgBox "Lütfen önce tarih giriniz!", vbCritical
    s1.Activate
    s1.[B1].Select
ElseIf WorksheetFunction.CountIf(s2.[E4:AI4], s1.[B1]) = 0 Then
    MsgBox "Kayıt tarihi bulunamadı!", vbCritical
    s1.Activate
    s1.[B1].Select
Else
    sut = WorksheetFunction.Match(s1.[B1], s2.[A4:AI4], 0)
    For i = 3 To son
        If s1.Cells(i, "G") = "" Then
            For sat = 5 To veri
                If s2.Cells(sat, "B") = s1.Cells(i, "D") And s2.Cells(sat, "C") = s1.Cells(i, "E") Then
                    s2.Cells(sat, sut) = s1.Cells(i, "F")
                    s1.Cells(i, "G") = "+"
                    test = s1.Cells(i, "C")
                    With s2.Cells(sat, sut)
                        .ClearComments
                        .AddComment
                        .Comment.Visible = False
                        .Comment.Text Text:=test
                    End With
                End If
            Next
        End If
    Next
End If
End Sub

 

[acetinnster]

Yusuf44 hocam merhabalar öncelikle ilgilendiğiniz için çok teşekkürler elinize sağlık

 

[acetinnster]

Yusuf44 hocam benim istediğim gibi yaptınız teşekkürler ancak benim atladığım bir husus var aktarma yapar iken şayet aktaracağı hücrede veri var ise hücredeki veri ile aktarılan sayıyı toplatarak o hücreye tekrar nasıl yazdırabiliriz. Açıklama kısmı önemli değil isterseniz o açıklama kısımlarının tamamını kaldırabiliriz tekrar tekrar teşekkürler ilginiz için

 

[YUSUF44]

Aşağıdaki gibi deneyin:

Sub aktar()
On Error Resume Next
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
son = WorksheetFunction.Max(3, s1.Cells(Rows.Count, "D").End(3).Row)
veri = WorksheetFunction.Max(3, s2.Cells(Rows.Count, "A").End(3).Row)
If s1.[B1] = "" Then
    MsgBox "Lütfen önce tarih giriniz!", vbCritical
    s1.Activate
    s1.[B1].Select
ElseIf IsDate(s1.[B1]) = False Then
    MsgBox "Lütfen önce tarih giriniz!", vbCritical
    s1.Activate
    s1.[B1].Select
ElseIf WorksheetFunction.CountIf(s2.[E4:AI4], s1.[B1]) = 0 Then
    MsgBox "Kayıt tarihi bulunamadı!", vbCritical
    s1.Activate
    s1.[B1].Select
Else
    sut = WorksheetFunction.Match(s1.[B1], s2.[A4:AI4], 0)
    For i = 3 To son
        If s1.Cells(i, "G") = "" Then
            For sat = 5 To veri
                If s2.Cells(sat, "B") = s1.Cells(i, "D") And s2.Cells(sat, "C") = s1.Cells(i, "E") Then
                    If IsNumeric(s1.Cells(i, "F")) = True Then
                        If s2.Cells(sat, sut) = "" Or IsNumeric(s2.Cells(sat, sut)) = False Then
                            s2.Cells(sat, sut) = s1.Cells(i, "F")
                        ElseIf IsNumeric(s2.Cells(sat, sut)) = True Then
                            s2.Cells(sat, sut) = s2.Cells(sat, sut) + s1.Cells(i, "F")
                        End If
                        s1.Cells(i, "G") = "+"
                        test = s1.Cells(i, "C")
                        With s2.Cells(sat, sut)
                            If IsEmpty(.Comment) Then
                                .AddComment
                                .Comment.Visible = False
                                .Comment.Text Text:=test
                            Else
                                eski = .Comment.Text
                                nota = eski & Chr(10) & test
                                .ClearComments
                                .AddComment
                                .Comment.Visible = False
                                .Comment.Text Text:=nota
                            End If
                        End With
                    End If
                End If
            Next
        End If
    Next
End If
End Sub