Skip to main content

AccessTr.neT


Çift Tık İle Aktar

Çift Tık İle Aktar

Çözüldü #1
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?
.zip dönüşüm tablosu İlçe.zip (Dosya Boyutu: 31,86 KB | İndirme Sayısı: 3)
malatyalı, 31-01-2010 tarihinden beri AccessTr.neT üyesidir.
Cevapla
#2
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
.rar dönüşüm tablosu İlçe.rar (Dosya Boyutu: 36,18 KB | İndirme Sayısı: 5)
Cevapla
#3
Ellerine Sağlık Ustam. Büyük bir dertten kurtardın beni
malatyalı, 31-01-2010 tarihinden beri AccessTr.neT üyesidir.
Cevapla
#4
Rica ederim abey.

Koddaki 18 =R sütunu.Hangi sütuna kadar aratacaksanız onu değiştirebilirsiniz.iki yerde var 18.
Cevapla
#5
Tamam Ustam
malatyalı, 31-01-2010 tarihinden beri AccessTr.neT üyesidir.
Cevapla
#6
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
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da