seçili hücre kaydetmek

[irfem4]

eklediğim örnek dosyada personel safyasında bulunan isimlerden herhangi bir hücre seçildiğinde seçili hücre satırındaki bilgilerin tablo sayfasına aktarılması mümkünmüdür. birden fazla seçim olduğunda tablo sayfasına alt alta listelenecek şekilde. orjinal dosyada 500 küsür kişi var. yardımlarınız için şimdiden teşekkurler

 

[volki_112]

eklediğim örnek dosyada personel safyasında bulunan isimlerden herhangi bir hücre seçildiğinde seçili hücre satırındaki bilgilerin tablo sayfasına aktarılması mümkünmüdür. birden fazla seçim olduğunda tablo sayfasına alt alta listelenecek şekilde. orjinal dosyada 500 küsür kişi var. yardımlarınız için şimdiden teşekkurler

personel sayfasının kod bölümüne bunu yaz. Personel sayfasında d sütununda çift tıklama yaptığın hücrenin o satır bilgilerini tablo sayfasına alır.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    ' =========================================================================
    ' === BÖL"ÜM 1: DEĞİŞKEN TANIMLAMALARI
    ' =========================================================================
    
    Dim wsDest As Worksheet      ' Hedef sayfa olan "tablo" sayfasını tutar
    Dim sourceRow As Long        ' Çift tıklanan satırın numarasını tutar
    Dim destRow As Long          ' Hedef sayfada yazılacak ilk boş satırın numarasını tutar
    
    ' --- GÖRSEL EFEKT İÇİN YENİ DEĞİŞKENLER ---
    Dim originalColor As Variant ' Hücrenin orijinal dolgu rengini tutar
    Dim originalPattern As Variant ' Hücrenin orijinal dolgu desenini tutar (ÇOK ÖNEMLİ)
    
    ' =========================================================================
    ' === BÖLÜM 2: KOŞULLARI KONTROL ETME
    ' =========================================================================
    
    If Target.Column <> 4 Or Target.Row <= 1 Then Exit Sub
    
    ' =========================================================================
    ' === BÖLÜM 3: VERİ AKTARMA İŞLEMİ
    ' =========================================================================
    
    Cancel = True ' Varsayılan çift tıklama eylemini iptal et
    
    ' --- GELİŞTİRİLMİŞ GÖRSEL GERİ BİLDİRİM ---
    With Target.Interior
        originalColor = .Color      ' 1. Orijinal rengi sakla
        originalPattern = .Pattern  ' 2. Orijinal deseni sakla ("Dolgu Yok" durumu için kritik)
        .Color = RGB(255, 255, 0)   ' 3. Hücreyi sarı yap
    End With
    
    DoEvents ' 4. Ekranda görünmesini sağla
    
    ' Saniyenin çok küçük bir kısmı kadar bekleyerek flaş efektinin netleşmesini sağla
    Application.Wait (Now + TimeValue("0:00:01") / 10) ' Saniyenin 1/10'u kadar bekle
    
    ' 5. Hücreyi TAMAMEN eski haline geri döndür
    With Target.Interior
        .Color = originalColor
        .Pattern = originalPattern
    End With
    ' --- GÖRSEL GERİ BİLDİRİM SONU ---
    
    ' --- Hedef sayfayı ayarla ---
    On Error Resume Next
    Set wsDest = ThisWorkbook.Worksheets("tablo")
    On Error GoTo 0
    
    If wsDest Is Nothing Then
        MsgBox "Verilerin aktarılacağı 'tablo' adında bir sayfa bulunamadı!", vbCritical, "Sayfa Hatası"
        Exit Sub
    End If
    
    ' --- Kaynak ve Hedef satırları belirle ---
    sourceRow = Target.Row
    destRow = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row + 1
    If destRow < 2 Then destRow = 2
    
    ' --- Veriyi Kopyala ---
    wsDest.Cells(destRow, "A").Resize(1, 6).Value = Me.Cells(sourceRow, "A").Resize(1, 6).Value
    
End Sub

 

[irfem4]

emeğine ellerine sağlık üstad. orjinal dosyaya uyarlayabilirsem inşallah süper olacak

 

[Muzaffer Ali]

Merhaba.
Alternatif kod.

Aşağıdaski kodu Personel sayfasının kod sayfasına kopyalayınız.
Personel sayfasında A:F hücre aralığında bir hücreyi çift tıkladığınızda kodlar otomatik çalışır.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Not Intersect(Target, Range("A2:F" & Rows.Count)) Is Nothing Then
        Range("A" & Target.Row & ":F" & Target.Row).Copy
        With Worksheets("tablo")
            .Range("A" & .Cells(Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial xlPasteValues
        End With
    End If
End Sub