AccessTr.neT
Çift Tık İle Aktar - Baskı Önizleme

+- AccessTr.neT (https://accesstr.net)
+-- Forum: Microsoft Excel (https://accesstr.net/forum-microsoft-excel.html)
+--- Forum: Excel Cevaplanmış Soruları (https://accesstr.net/forum-excel-cevaplanmis-sorulari.html)
+--- Konu Başlığı: Çift Tık İle Aktar (/konu-cift-tik-ile-aktar.html)



Çift Tık İle Aktar - malatyalı - 27/04/2021

Es Selamün Aleyküm

Ustam malumunuzdur ki 30/04/2021 - 17/05/2021 tarihleri arasında Tam Kapanma durumuna geçildi. Bu sebepten dolayı personellere görev belgesi zaruriyeti ortaya çıktı.

Ekli dosyamın 2021 Mayıs Ayı sekmesinde personellerin görevli olduğu günlere "Görevli" ibaresi yazılı bir çizelgemiz mevcut. Bu çizelge aslına uygun ama personellerin tamamı alınmamış.
Sizlerden ricam eğer mümkünse 2021 Mayıs ayı sekmesinde Personelin adı soyadının bulunduğu sütuna çift tık ile Görev Belgesi sekmesinde;
Adı soyadı, >> C9 hücresine
T.C kimlik numarası, >> C10 hücresine
Görev Unvanı >> C12 hücresine
Görev Yeri >> C11 hücresine ve
03/05/2021 - 17/05/2021 tarihlerinde "Görevli" yazan tarihleri de 15. Satıra yan yana yazdırmak içinyardımcı olabilir misiniz?


RE: Çift Tık İle Aktar - feraz - 27/04/2021

Aleyküm selam abey dosyayı inceleyin.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim bul As Range, i As Integer, say As Integer

With Sayfa7
    .Range("C9:i16").ClearContents
    If Not Intersect(Target, Range("A6:A" & Rows.Count)) Is Nothing Then Exit Sub
    Set bul = Range(Cells(Target.Row, 8), Cells(Target.Row, 18)).Find("Görevli", , xlValues, 1)
    say = 3
        .Range("C9").Value = Target.Value
        .Range("C10").Value = Target.Offset(, 3).Value
        .Range("C12").Value = Target.Offset(, 1).Value
        .Range("C11").Value = Target.Offset(, 2).Value
    If Not bul Is Nothing Then
        For i = 8 To 18 '8=H  18 =r sütun
            If LCase(Cells(bul.Row, i).Value) = "görevli" Then
                .Cells(15, say).Value = Cells(5, i).Value
                say = say + 1
            End If
        Next
    End If
End With
Set bul = Nothing
MsgBox "Aktarildi", vbInformation + vbOKOnly, "Bitti"
End Sub



RE: Çift Tık İle Aktar - malatyalı - 27/04/2021

Ellerine Sağlık Ustam. Büyük bir dertten kurtardın beni


RE: Çift Tık İle Aktar - feraz - 27/04/2021

Rica ederim abey.

Koddaki 18 =R sütunu.Hangi sütuna kadar aratacaksanız onu değiştirebilirsiniz.iki yerde var 18.


RE: Çift Tık İle Aktar - malatyalı - 27/04/2021

Tamam Ustam


Re: Çift Tık İle Aktar - feraz - 27/04/2021

Alttaki kodu kullanırsanız son sütun numarasını otomatik bulup orda Görevlilerin tarihini getirir.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim bul As Range, i As Integer, say As Integer
Dim sonSutun As Integer, ilkSutun As Byte

With Sayfa7
   .Range(.Range("C9"), .Cells(16, Columns.Count)).ClearContents
    ilkSutun = 8 'Tarih baslangis sütun
    sonSutun = Cells(5, Columns.Count).End(xlToLeft).Column
    If sonSutun < ilkSutun Then
        MsgBox "Tarih yok..", vbCritical, "Hata"
        Exit Sub
    End If
   
    If Not Intersect(Target, Range("A6:A" & Rows.Count)) Is Nothing Then Exit Sub
    Set bul = Range(Cells(Target.Row, ilkSutun), Cells(Target.Row, Columns.Count)).Find("Görevli", , xlValues, 1)
    say = 3
        .Range("C9").Value = Target.Value
        .Range("C10").Value = Target.Offset(, 3).Value
        .Range("C12").Value = Target.Offset(, 1).Value
        .Range("C11").Value = Target.Offset(, 2).Value
    If Not bul Is Nothing Then
        For i = ilkSutun To sonSutun
            If LCase(Cells(bul.Row, i).Value) = "görevli" Then
                .Cells(15, say).Value = Cells(5, i).Value
                say = say + 1
            End If
        Next
    End If
End With
Set bul = Nothing
MsgBox "Aktarildi", vbInformation + vbOKOnly, "Bitti"
End Sub