Soru Tek Tık ile Kişisel Rapor Oluşturma

[Macaroglu]

Merhabalar;

Eklediğim dosyada 2 çalışma sayfasından oluşan bir excel dosyası var.
Bu dosyanın 1. sayfasına ben hergün manuel girdi ekliyorum.
Ama ay sonunda istediğim bir kişi için adının solundaki butona tıklayıp 1. sayfadan çekilen verilerle 2. sayfada otomatik rapor oluşturmak istiyorum.

Dosyanın içerisinde el ile doldurduğum rapor görüntüsü de bulunuyor.

Bana bu konuda yardımcı olabilir misiniz?

 

[Macaroglu]

İnceleme fırsatı bulan oldu mu acaba?

 

[halit3]

Merhaba bilinmiyor diye yazan bölümlerin nereden geldiğini bilmediğim için boş geçtim
yapmanız gereken aktarmak istediğiniz satıra imleçle veya enter ile veya mause ile gelin ve aktar düğmesine tıklayın

Sub aktar()


sh1 = "Sayfa1"
sh2 = "Sayfa2"

Worksheets(sh2).Range("c5:c21").ClearContents

sat = ActiveWindow.RangeSelection.Row



Sheets(sh2).Cells(5, 3).Value = Sheets(sh1).Cells(sat, "b").Value
Sheets(sh2).Cells(6, 3).Value = Sheets(sh1).Cells(sat, "c").Value

topla1 = ""
say = 0
For i = 5 To 35
If Sheets(sh1).Cells(sat, i).Value = "X" Then

say = say + 1
If say = 1 Then

topla1 = Sheets(sh1).Cells(2, i).Value
Else
topl1a = topla1 & ", " & Sheets(sh1).Cells(2, i).Value
End If
End If
Next

Sheets(sh2).Cells(7, 3).Value = topla1

'veri1 = WorksheetFunction.CountIf(Range(Cells(sat, "e"), Cells(sat, "ah")), "X")
'Sheets(sh2).Cells(7, 3).Value = veri1

topla2 = 0
For i = 5 To 35
If Sheets(sh1).Cells(sat, i).Value < 9.5 And Sheets(sh1).Cells(sat, i).Value > 1 Then
topla2 = topla2 + 1
End If
Next


Sheets(sh2).Cells(8, 3).Value = topla2

topla3 = ""
say2 = 0
For i = 5 To 35
If Sheets(sh1).Cells(sat, i).Value < 9.5 And Sheets(sh1).Cells(sat, i).Value > 0 Then
say2 = say2 + 1
If say2 = 1 Then
topla3 = Sheets(sh1).Cells(2, i).Value
Else
topla3 = topla3 & ", " & Sheets(sh1).Cells(2, i).Value
End If
End If
Next

Sheets(sh2).Cells(9, 3).Value = topla3

Sheets(sh2).Cells(10, 3).Value = WorksheetFunction.CountIf(Range(Cells(sat, "e"), Cells(sat, "ah")), "X")
Sheets(sh2).Cells(11, 3).Value = Sheets(sh1).Cells(sat, "al").Value
Sheets(sh2).Cells(12, 3).Value = "bilnmiyor"
Sheets(sh2).Cells(13, 3).Value = Sheets(sh1).Cells(sat, "aj").Value
Sheets(sh2).Cells(14, 3).Value = "bilnmiyor"
Sheets(sh2).Cells(15, 3).Value = Sheets(sh1).Cells(sat, "ak").Value
Sheets(sh2).Cells(16, 3).Value = Sheets(sh1).Cells(sat, "al").Value
Sheets(sh2).Cells(17, 3).Value = Sheets(sh1).Cells(sat, "am").Value
Sheets(sh2).Cells(18, 3).Value = Sheets(sh1).Cells(sat, "an").Value
Sheets(sh2).Cells(19, 3).Value = "bilnmiyor"
Sheets(sh2).Cells(20, 3).Value = Sheets(sh1).Cells(sat, "ao").Value
Sheets(sh2).Cells(21, 3).Value = Sheets(sh1).Cells(sat, "aq").Value


MsgBox "İşlem tamam..."

End Sub

 

[Macaroglu]

Halit Bey
Öncelikle yardımınız için teşekkür ederim.
Bilinmiyor kısımlarını düzeltmeye çalıştım.
Ama yapamadım. Çünkü aynı sütunda yer alan alt alta hücreler.
1. bilinmiyor A kişisi için 1. sayfadaki ai4 hücresi
2. bilinmiyor yine A kişisi için 1. sayfadaki aj4 hücresi olması gerekiyor.
Diğer "bilinmiyorları ben düzelttim.

 

[Macaroglu]

Sheets(sh2).Cells(12, 3).Value = Sheets(sh1).Cells(sat + 1, "ai").Value
şeklinde düzelttim. Teşekkürler

 

[halit3]

dosyaya bir kolaylık daha getirdim sayfa1 de isimler hücresi B sutünü isimlere hızlı şekilde iki kere tıklayıncada kod aktarıyor.

 

[Macaroglu]

dosyaya bir kolaylık daha getirdim sayfa1 de isimler hücresi B sutünü isimlere hızlı şekilde iki kere tıklayıncada kod aktarıyor.

Halit Bey Çok kullanışlı olmuş teşekkürler.

Ben Bilinmiyor kısımlarını güncelledim.
Ancak Gelmediği günlerin tarihlerini yazdırma kısmı çalışmıyor.
Ekteki dosyaya bu hatayı güncelleyip, son yaptığınız kolaylığı da ekleyebilir misiniz?

 

[halit3]

buyurun

 

[Macaroglu]

Çok teşekkür ederim

 

[sakoz]

Merhaba ,

Dosyayı dosya.co gibi bir siteye yükleyebilirmisiniz lütfen...
Teşekkürler...

 

[kissofh3ll]

merhaba benim de bu tarz bir şeye ihtiyacım var yardımcı olur musunuz?