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

Katılım
26 Nisan 2021
Mesajlar
178
Excel Vers. ve Dili
TR 2021
Altın Üyelik Bitiş Tarihi
27-04-2022
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
 

Ekli dosyalar

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,073
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Aşağıdaki kodu deneyin:

PHP:
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
 
Katılım
26 Nisan 2021
Mesajlar
178
Excel Vers. ve Dili
TR 2021
Altın Üyelik Bitiş Tarihi
27-04-2022
Yusuf hocam emeklerinize çok teşekkür ederim. Fakat aynı sayfada ikinci bir tıklamada yine aynı kaydı yapıyor bunu engellememiz gerekli.
 

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,073
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Aşağıdaki gibi deneyin:

Kod:
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
 
Katılım
26 Nisan 2021
Mesajlar
178
Excel Vers. ve Dili
TR 2021
Altın Üyelik Bitiş Tarihi
27-04-2022
Allah sizden razı olsun çok çok teşekkür ederim.
 
Üst