Puantaj aktarma

[burhancavus61]

Aylık tuttuğum puantaj sayfasını arşiv sayfasına tarih ve kişi bazlı aktarabilirmiyim. Aylık puantajı siliyorum Yıllık olarak arşiv sayfasında biriktimem lazım. Kişiler yıllık bazda giriş çıkış yapıyor kişiler değişken. Örek dosyam ekte

 

[Asri]

Arşivde TCNO var ise puntaj daki tarihleri arşiv sayfasında günceller.
Arşiv de TCNO yok ise arşive ekler ve ilgili tarihleri günceller.
Arşiv de tarih olup ilgili tarih Puantajda yok ise işlem yapmaz.

Sub arsivle()
   'Asri Akdeniz - www.asriakdeniz.com - asriakdeniz@gmail.com
   Set shp = Sheets("Puantaj")
   Set sha = Sheets("Arşiv")

   sonsatirp = shp.Cells(shp.Rows.Count, "B").End(3).Row
   sonsutunp = shp.Cells(2, shp.Columns.Count).End(xlToLeft).Column
  
   For j = 3 To sonsatirp

       tcno = shp.Cells(j, "B").Value
       satir = 0
       satir = varmi(tcno)
       If satir > 0 And tcno <> "" Then
         For i = 5 To sonsutunp
            tarih = shp.Cells(2, i).Value
            sutun = varmic(tarih)
            sutun = 0
            If sutun > 0 And tarih <> "" Then
               sha.Cells(satir, sutun).Value = shp.Cells(j, i).Value
            End If
          
         Next i
       ElseIf tcno <> "" Then
          sonsatira = sha.Cells(sha.Rows.Count, "B").End(3).Row + 1
          If sonsatira < 3 Then sonsatira = 3
          sha.Cells(sonsatira, "B").Value = shp.Cells(j, "B").Value
          sha.Cells(sonsatira, "C").Value = shp.Cells(j, "C").Value
          sha.Cells(sonsatira, "D").Value = shp.Cells(j, "D").Value
          j = j - 1
          
       End If
   Next j
End Sub

Function varmi(bilgi) As Long
    Set sayfak = Sheets("Arşiv").Range("B:B").Find(bilgi, , xlValues, xlWhole)
    If Not sayfak Is Nothing Then
       varmi = sayfak.Row
       Exit Function
    End If
    varmi = 0
End Function

Function varmic(bilgi) As Long
   Set sayfak = Sheets("Arşiv").Range("E2:NZ2").Find(CDate(bilgi), , xlFormulas, xlWhole)
   If Not sayfak Is Nothing Then
       varmic = sayfak.Column
       Exit Function
    End If
    varmic = 0
End Function

 

[burhancavus61]

Puantaj bilgilerinide aktarmam lazım. X F vb. bilgileride

 

[Asri]

Puantaj bilgilerinide aktarmam lazım. X F vb. bilgileride

Puantaj sayfasındaki tüm bilgiler arşiv e aktarılıyor. X F nedir anlamadım.
Sizi programı çalıştırdınız mı?

Puantaj sayfasındaki Arşiv Güncelle butonunu kullandınız mı?

 

[burhancavus61]

Tekrar kontrol ediyorum

 

[burhancavus61]

Arşiv güncelle deyince kimlik no ve isimler arşiv sayfasına geliyor ama tarihlerin altındaki Harf kodları gelmiyor.

 

[Asri]

Kodda kayma olmuş
Kod ve dosya güncellendi.

Sub arsivle()
   'Asri Akdeniz - www.asriakdeniz.com - asriakdeniz@gmail.com
   Set shp = Sheets("Puantaj")
   Set sha = Sheets("Arşiv")

   sonsatirp = shp.Cells(shp.Rows.Count, "B").End(3).Row
   sonsutunp = shp.Cells(2, shp.Columns.Count).End(xlToLeft).Column
  
   Application.ScreenUpdating = False
   For j = 3 To sonsatirp

       tcno = shp.Cells(j, "B").Value
       satir = 0
       satir = varmi(tcno)
       If satir > 0 And tcno <> "" Then
         For i = 5 To sonsutunp
            tarih = shp.Cells(2, i).Value
            sutun = 0
            sutun = varmic(tarih)
            If sutun > 0 And tarih <> "" Then
               sha.Cells(satir, sutun).Value = shp.Cells(j, i).Value
            End If
          
         Next i
       ElseIf tcno <> "" Then
          sonsatira = sha.Cells(sha.Rows.Count, "B").End(3).Row + 1
          If sonsatira < 3 Then sonsatira = 3
          sha.Cells(sonsatira, "B").Value = shp.Cells(j, "B").Value
          sha.Cells(sonsatira, "C").Value = shp.Cells(j, "C").Value
          sha.Cells(sonsatira, "D").Value = shp.Cells(j, "D").Value
          j = j - 1
          
       End If
   Next j
   Application.ScreenUpdating = True
   MsgBox ("Arşivleme işlemi tamamlandı")
End Sub

Function varmi(bilgi) As Long
    Set sayfak = Sheets("Arşiv").Range("B:B").Find(bilgi, , xlValues, xlWhole)
    If Not sayfak Is Nothing Then
       varmi = sayfak.Row
       Exit Function
    End If
    varmi = 0
End Function

Function varmic(bilgi) As Long
   Set sayfak = Sheets("Arşiv").Range("E2:NZ2").Find(CDate(bilgi), , xlFormulas, xlWhole)
   If Not sayfak Is Nothing Then
       varmic = sayfak.Column
       Exit Function
    End If
    varmic = 0
End Function

 

[burhancavus61]

Teşekkür ederim

 

[burhancavus61]

Çok teşekkürler elinize sağlık süpersiniz.