Soru Çift Tıklama İle Diğer Sayfaya Veri Aktarma / Kopyalama

[reosman]

F sütünunda kod var çift tıklandığında işaretliyor ve G sütunundaki toplam kayıt sayısından düşüyor. istenilen; yine F sütununa çift tıklandığında yapılan işlemlere ilaveten iz sayfasına A sütunu hariç olmak üzere tüm satırın kopyalanması ve aynı bilgilere sahip bir satır kopyalanmak isterse uyarı vererek kopyalanmaması, kopyaların üzerine değil her seferinde bir alt satıra kopyalanması. Vereceğiniz bilgiler için şimdiden çok teşekkür ederim. Saygılarımla.b

 

[YUSUF44]

Aşağıdaki kodu deneyin:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim Alan As Range
    Dim yeni As Integer
    Dim a, son As Integer
    Set Alan = Range("F2:F1045876")
    If Intersect(Target, Alan) Is Nothing Then Exit Sub
    Cancel = True
    Target = IIf(IsEmpty(Target) = False, "", "R")
    son = Sheets("İz").Cells(Rows.Count, "B").End(3).Row
    a = Target.Row
    If WorksheetFunction.CountIfs(Sheets("İz").Range("B1:B" & son), Cells(a, "B"), Sheets("İz").Range("C1:C" & son), Cells(a, "C"), _
        Sheets("İz").Range("D1:D" & son), Cells(a, "D"), Sheets("İz").Range("E1:E" & son), Cells(a, "E"), Sheets("İz").Range("F1:F" & son), Cells(a, "F")) = 0 Then
        Range("B" & a & ":F" & a).Copy Sheets("İz").Cells(son + 1, "B")
        Sheets("İz").Cells(son + 1, "A") = son
    Else
        MsgBox "İşaretlenen kayıt İz sayfasında mevvuttur!", vbExclamation
    End If
End Sub

 

[reosman]

Yusuf hocam emeklerinize çok teşekkür ederim. Fakat aynı sayfada ikinci bir tıklamada yine aynı kaydı yapıyor bunu engellememiz gerekli.

 

[YUSUF44]

Aşağıdaki gibi deneyin:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim Alan As Range
    Dim yeni As Integer
    Dim a, son As Integer
    Set Alan = Range("F2:F1045876")
    If Intersect(Target, Alan) Is Nothing Then Exit Sub
    Cancel = True
    If IsEmpty(Target) Then
        Target = "R"
        son = Sheets("İz").Cells(Rows.Count, "B").End(3).Row
        a = Target.Row
        If WorksheetFunction.CountIfs(Sheets("İz").Range("B1:B" & son), Cells(a, "B"), Sheets("İz").Range("C1:C" & son), Cells(a, "C"), _
            Sheets("İz").Range("D1:D" & son), Cells(a, "D"), Sheets("İz").Range("E1:E" & son), Cells(a, "E")) = 0 Then
            Range("B" & a & ":F" & a).Copy Sheets("İz").Cells(son + 1, "B")
            Sheets("İz").Cells(son + 1, "A") = son
        Else
            MsgBox "İşaretlenen kayıt İz sayfasında mevvuttur!", vbExclamation
        End If
    Else
        Target.ClearContents
    End If
End Sub

 

[reosman]

Allah sizden razı olsun çok çok teşekkür ederim.