puantaj kodu aktarma

[burhancavus61]

örnek dosyada puantaj sayfasından F.mesai sayfasına F ve FA kodlarını aktarıyorum ve aktarılan kodlara karşılık mesai saati yazıyorum. puantaja ilave kişi yada yeni kod işleme yaptığım zaman eski kaydı silip tüm kodları tekrar aktarıyor. dolayısıyla işlediğim saat kayma yapmış oluyor. isteğim şu kod aktardıktan sonra önce aktardıklarımda silme ve ilave yaptığımda sildiğim kodun mesaisini silmeli yeni girilenleride en son satıra eklemeliki önce girdiğim kodlara karşılık gelen saat bilgileri kaymasın. yani aynı olan kayıtları tekrar aktarmasın. yeni girdiğim kişilerde F ve FA kodları varsa en alta eklemeye devam etsin. örnek kodu yine burada sağolsun Ziyenttin bey yardımcı olmuştu.

 

[Ziynettin]

Şartlarınıza göre kodun kısaltılmış hali.


Aktar kodu.

Sub FMesaiAktar()

Dim s1 As Worksheet, s2 As Worksheet, dc As Object
Set s1 = Sheets("Puantaj")
Set s2 = Sheets("F.Mesai")

    Set dc = CreateObject("scripting.dictionary")
    son2 = s2.Cells(Rows.Count, "B").End(3).Row
    a = s2.Range("B4:B" & son2).Value
    For i = 1 To UBound(a)
        dc(CStr(a(i, 1))) = ""
    Next i

son = s1.Cells(Rows.Count, "J").End(3).Row

a = s1.Range("K5:AR" & son).Value
ReDim b(1 To Rows.Count, 1 To 4)
    For i = 2 To UBound(a)
        If a(i, 1) <> "" Then
        tc = CStr(a(i, 1))
            If Not dc.exists(tc) Then
                For j = 3 To UBound(a, 2)
                    If a(i, j) = "F" Or a(i, j) = "FA" Then
                        say = say + 1
                        b(say, 1) = a(i, 1)
                        b(say, 2) = a(i, 2)
                        b(say, 3) = a(1, j)
                        b(say, 4) = a(i, j)
                    End If
                Next j
            End If
        End If
    Next i

    If say > 0 Then
        If son2 < 4 Then son2 = 3
        s2.Cells(son2 + 1, 2).Resize(say).NumberFormat = "@"
        s2.Cells(son2 + 1, 4).Resize(say).NumberFormat = "dd.mm.yyyy"
        s2.Cells(son2 + 1, 2).Resize(say, 4) = b
        MsgBox "İşlem tamam.", vbInformation
    Else
        MsgBox "Aktarılacak veri bulunamadı.", vbCritical
    End If
End Sub

Kontrol kodu.

Sub Kontrol()
Dim s1 As Worksheet, s2 As Worksheet, dc As Object
Set s1 = Sheets("Puantaj")
Set s2 = Sheets("F.Mesai")

Set dc = CreateObject("scripting.dictionary")

son = s1.Cells(Rows.Count, "J").End(3).Row
a = s1.Range("K5:AR" & son).Value

ReDim b(1 To Rows.Count, 1 To 4)

    For i = 2 To UBound(a)
        If a(i, 1) <> "" Then
            tc = CStr(a(i, 1))
            If Not dc.exists(tc) Then
                For j = 3 To UBound(a, 2)
                    If a(i, j) = "F" Or a(i, j) = "FA" Then
                        krt = a(i, 1) & "|" & a(i, 2) & "|" & a(1, j) & "|" & a(i, j)
                    dc(krt) = 1
                    End If
                Next j
            End If
        End If
    Next i
    
    son = s2.Cells(Rows.Count, "B").End(3).Row
    a = s2.Range("B4:E" & son).Value
    
    For i = 1 To UBound(a)
        krt = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4)
        If Not dc.exists(krt) Then
            For j = 1 To 4
                a(i, j) = Empty
            Next j
        Else
            For j = 1 To 4
                a(i, j) = a(i, j)
            Next j
        End If
    Next i

   s2.[B4].Resize(UBound(a), UBound(a, 2)) = a
    
MsgBox "Konrol İşlemi Tamamlandı.", vbInformation
End Sub

Çalışma dosyanız.

 

[burhancavus61]

Valla hocam allah razı olsun derin bir nefes çektim. Yapmaya çalışıyordum ama uzun uzadıya olacaktı başka sayfaya aktararark yapmaya çalışacaktım. İyiki bu grup var.

 

[burhancavus61]

hocam bi eksiği var önce aktarılan puantajdan örneğin ali erginin 15 indeki f kodunu silersem onuda aktarılan kısımdan temizlese silmeden

 

[burhancavus61]

yani puantajda düzeltme yapmışsam onuda kaldırması lazım

 

[Ziynettin]

Burhan bey;

#2. iletide ekli dosyayı bakınız.

 

[burhancavus61]

kontrol edeceğim hocam sağolun dönüş yapacağım size

 

[burhancavus61]

Hocam F veya FA kodu ilave ettiğimde ekleme yada sildiğimde silme yapmıyor.