Yatay Görünen Puantajın Dikeye Çevirilmesi Hk.

[baykan_m]

Merhaba Arkadaşlar,

Benim aylık puantaj için hazır bir şablonum var. Bu şablonun bordro programına aktarımı için dikey olarak çevirilmesi gerekiyor. Ben birkaç deneme yaptım ancak başarılı olamadım. İlgili excel ekte olup, detaylı açıklamalar SAP-Puantaj ve SAP-Devamsızlıklar sayfaları içerisinde yer almaktadır.

Yardımcı olanlara şimdiden çok teşekkür ederim.

 

[ÖmerFaruk]

Aşağıdaki kodları boş bir modül içine kopyalayıp kullanabilirsiniz.

Sub SapPuantaj()
    Dim Sh1 As Worksheet, Sh2 As Worksheet, Veri, xAy As Integer, xYıl As Integer, PuantajKod, i As Integer, k As Integer
    Set Sh1 = Worksheets("Puantaj")
    Set Sh2 = Worksheets("SAP-PUANTAJ")
    Son = Sh1.Range("A" & Rows.Count).End(3).Row
    Veri = Sh1.Range("A1:AZ" & Son).Value
    For i = 0 To 11
        If Split(Trim(Veri(1, 7)), " ")(0) = UCase(Format(DateAdd("m", i, DateSerial(2022, 1, 1)), "mmmm")) Then
            xAy = i + 1
            xYıl = Split(Trim(Veri(1, 7)), " ")(2)
            Exit For
        End If
    Next i
    AySonu = DateAdd("m", 1, DateSerial(xYıl, xAy, 1)) - 1
    PuantajKod = Array(38, 39, 40, 47, 48, 49, 50, 51, 52)
    ReDim Liste(1 To (Son - 3) * 9, 1 To 4)
    For i = 4 To UBound(Veri)
        If Veri(i, 4) <> "" And Veri(i, 4) <> 0 And (Veri(i, 5) = "" Or Veri(i, 5) = 0) Then
            For k = 1 To 9
                If Veri(i, PuantajKod(k - 1)) > 0 Then
                    Say = Say + 1
                    Liste(Say, 1) = Veri(i, 1)
                    Liste(Say, 2) = Veri(1, PuantajKod(k - 1))
                    Liste(Say, 3) = AySonu
                    Liste(Say, 4) = Veri(i, PuantajKod(k - 1))
                End If
            Next k
        End If
    Next i
    Sh2.Range("A2:D" & Rows.Count).ClearContents
    Sh2.Range("A2").Resize(Say, 4) = Liste
    Sh2.Range("A2").Resize(Say, 4).Sort Key1:=Sh2.[A2], Order1:=1, Key2:=Sh2.[D2], Order2:=1, Key3:=Sh2.[B2], ORder3:=1
    i = Empty: k = Empty: xAy = Empty: xYıl = Empty
    Erase Veri: Erase PuantajKod: Erase Liste: Set Sh1 = Nothing: Set Sh2 = Nothing
End Sub

Sub SapDevamsızlık()
    Dim Sh1 As Worksheet, Sh2 As Worksheet, Bul As Range
    Dim Veri, Liste, Bulunan(), DevamKod
    Dim i As Integer, k As Integer, x As Integer, Say As Integer, ListeSay As Integer, xAy As Integer, xYıl As Integer
    Set Sh1 = Worksheets("Puantaj")
    Set Sh2 = Worksheets("SAP-DEVAMSIZLIK")
    Son = Sh1.Range("A" & Rows.Count).End(3).Row
    Veri = Sh1.Range("A1:AZ" & Son).Value
    For i = 0 To 11
        If Split(Trim(Veri(1, 7)), " ")(0) = UCase(Format(DateAdd("m", i, DateSerial(2022, 1, 1)), "mmmm")) Then
            xAy = i + 1
            xYıl = Split(Trim(Veri(1, 7)), " ")(2)
            Exit For
        End If
    Next i
    DevamKod = [{100, "S"; 110,"E"; 120,"R";200,"İ";230,"D";290,"K";350,"F"}]

    ReDim Liste(1 To (Son - 3) * 31, 1 To 4)
    For i = 4 To UBound(Veri)
        For k = LBound(DevamKod) To UBound(DevamKod)
            Set Bul = Sh1.Range("G" & i, "AK" & i).Find(DevamKod(k, 2))
            If Not Bul Is Nothing Then
                Say = Say + 1
                ReDim Preserve Bulunan(1 To Say)
                Bulunan(Say) = Sh1.Cells(3, Bul.Column)
                Bulunanilk = Sh1.Cells(3, Bul.Column)
                Do
                    Set Bul = Range("G" & i, "AK" & i).FindNext(Bul)
                        If Bul Is Nothing Then Exit Do
                        If Bulunanilk = Sh1.Cells(3, Bul.Column) Then Exit Do
                        Say = Say + 1
                        ReDim Preserve Bulunan(1 To Say)
                        Bulunan(Say) = Sh1.Cells(3, Bul.Column)
                Loop
            End If
            For x = 1 To Say
                ListeSay = ListeSay + 1
                Liste(ListeSay, 1) = Sh1.Range("A" & i)
                Liste(ListeSay, 2) = DevamKod(k, 1)
                Liste(ListeSay, 3) = DateSerial(xYıl, xAy, Bulunan(x))
                Liste(ListeSay, 4) = DateSerial(xYıl, xAy, Bulunan(x))
                Do While x < Say
                    If Bulunan(x) + 1 = Bulunan(x + 1) Then
                        x = x + 1
                        Liste(ListeSay, 4) = DateSerial(xYıl, xAy, Bulunan(x))
                    Else
                        Exit Do
                    End If
                Loop
            Next x
            If Say > 0 Then
                Say = 0
                Erase Bulunan
            End If
        Next k
    Next i
    Sh2.Range("A2:D" & Rows.Count).ClearContents
    Sh2.Range("A2").Resize(ListeSay, 4) = Liste
    Sh2.Range("A2").Resize(ListeSay, 4).Sort Key1:=Sh2.[A2], Order1:=1, Key2:=Sh2.[C2], Order2:=1
    
    i = Empty: k = Empty: x = Empty: Say = Empty: ListeSay = Empty: xAy = Empty: xYıl = Empty
    Set Sh1 = Nothing: Set Sh2 = Nothing: Set Bul = Nothing
    Erase Veri: Erase Liste: Erase Bulunan: Erase DevamKod:
End Sub

 

[baykan_m]

Aşağıdaki kodları boş bir modül içine kopyalayıp kullanabilirsiniz.

Sub SapPuantaj()
    Dim Sh1 As Worksheet, Sh2 As Worksheet, Veri, xAy As Integer, xYıl As Integer, PuantajKod, i As Integer, k As Integer
    Set Sh1 = Worksheets("Puantaj")
    Set Sh2 = Worksheets("SAP-PUANTAJ")
    Son = Sh1.Range("A" & Rows.Count).End(3).Row
    Veri = Sh1.Range("A1:AZ" & Son).Value
    For i = 0 To 11
        If Split(Trim(Veri(1, 7)), " ")(0) = UCase(Format(DateAdd("m", i, DateSerial(2022, 1, 1)), "mmmm")) Then
            xAy = i + 1
            xYıl = Split(Trim(Veri(1, 7)), " ")(2)
            Exit For
        End If
    Next i
    AySonu = DateAdd("m", 1, DateSerial(xYıl, xAy, 1)) - 1
    PuantajKod = Array(38, 39, 40, 47, 48, 49, 50, 51, 52)
    ReDim Liste(1 To (Son - 3) * 9, 1 To 4)
    For i = 4 To UBound(Veri)
        If Veri(i, 4) <> "" And Veri(i, 4) <> 0 And (Veri(i, 5) = "" Or Veri(i, 5) = 0) Then
            For k = 1 To 9
                If Veri(i, PuantajKod(k - 1)) > 0 Then
                    Say = Say + 1
                    Liste(Say, 1) = Veri(i, 1)
                    Liste(Say, 2) = Veri(1, PuantajKod(k - 1))
                    Liste(Say, 3) = AySonu
                    Liste(Say, 4) = Veri(i, PuantajKod(k - 1))
                End If
            Next k
        End If
    Next i
    Sh2.Range("A2:D" & Rows.Count).ClearContents
    Sh2.Range("A2").Resize(Say, 4) = Liste
    Sh2.Range("A2").Resize(Say, 4).Sort Key1:=Sh2.[A2], Order1:=1, Key2:=Sh2.[D2], Order2:=1, Key3:=Sh2.[B2], ORder3:=1
    i = Empty: k = Empty: xAy = Empty: xYıl = Empty
    Erase Veri: Erase PuantajKod: Erase Liste: Set Sh1 = Nothing: Set Sh2 = Nothing
End Sub

Sub SapDevamsızlık()
    Dim Sh1 As Worksheet, Sh2 As Worksheet, Bul As Range
    Dim Veri, Liste, Bulunan(), DevamKod
    Dim i As Integer, k As Integer, x As Integer, Say As Integer, ListeSay As Integer, xAy As Integer, xYıl As Integer
    Set Sh1 = Worksheets("Puantaj")
    Set Sh2 = Worksheets("SAP-DEVAMSIZLIK")
    Son = Sh1.Range("A" & Rows.Count).End(3).Row
    Veri = Sh1.Range("A1:AZ" & Son).Value
    For i = 0 To 11
        If Split(Trim(Veri(1, 7)), " ")(0) = UCase(Format(DateAdd("m", i, DateSerial(2022, 1, 1)), "mmmm")) Then
            xAy = i + 1
            xYıl = Split(Trim(Veri(1, 7)), " ")(2)
            Exit For
        End If
    Next i
    DevamKod = [{100, "S"; 110,"E"; 120,"R";200,"İ";230,"D";290,"K";350,"F"}]

    ReDim Liste(1 To (Son - 3) * 31, 1 To 4)
    For i = 4 To UBound(Veri)
        For k = LBound(DevamKod) To UBound(DevamKod)
            Set Bul = Sh1.Range("G" & i, "AK" & i).Find(DevamKod(k, 2))
            If Not Bul Is Nothing Then
                Say = Say + 1
                ReDim Preserve Bulunan(1 To Say)
                Bulunan(Say) = Sh1.Cells(3, Bul.Column)
                Bulunanilk = Sh1.Cells(3, Bul.Column)
                Do
                    Set Bul = Range("G" & i, "AK" & i).FindNext(Bul)
                        If Bul Is Nothing Then Exit Do
                        If Bulunanilk = Sh1.Cells(3, Bul.Column) Then Exit Do
                        Say = Say + 1
                        ReDim Preserve Bulunan(1 To Say)
                        Bulunan(Say) = Sh1.Cells(3, Bul.Column)
                Loop
            End If
            For x = 1 To Say
                ListeSay = ListeSay + 1
                Liste(ListeSay, 1) = Sh1.Range("A" & i)
                Liste(ListeSay, 2) = DevamKod(k, 1)
                Liste(ListeSay, 3) = DateSerial(xYıl, xAy, Bulunan(x))
                Liste(ListeSay, 4) = DateSerial(xYıl, xAy, Bulunan(x))
                Do While x < Say
                    If Bulunan(x) + 1 = Bulunan(x + 1) Then
                        x = x + 1
                        Liste(ListeSay, 4) = DateSerial(xYıl, xAy, Bulunan(x))
                    Else
                        Exit Do
                    End If
                Loop
            Next x
            If Say > 0 Then
                Say = 0
                Erase Bulunan
            End If
        Next k
    Next i
    Sh2.Range("A2:D" & Rows.Count).ClearContents
    Sh2.Range("A2").Resize(ListeSay, 4) = Liste
    Sh2.Range("A2").Resize(ListeSay, 4).Sort Key1:=Sh2.[A2], Order1:=1, Key2:=Sh2.[C2], Order2:=1
   
    i = Empty: k = Empty: x = Empty: Say = Empty: ListeSay = Empty: xAy = Empty: xYıl = Empty
    Set Sh1 = Nothing: Set Sh2 = Nothing: Set Bul = Nothing
    Erase Veri: Erase Liste: Erase Bulunan: Erase DevamKod:
End Sub

Merhaba Ömer Faruk Bey,

Elinize sağlık çok teşekkür ederim. Devamsızlık sayfası istediğim gibi geldi ancak Puantaj sayfası boş geliyor. Bir de başlıklarda gelebilirse çok sevinirim. Yardımınız için çok teşekkür ederim.

 

[ÖmerFaruk]

Gönderdiğiniz örnek dosya bende açık. Ve dediğiniz gibi bir hata vermiyor. Dosyanızın bir yerlerini değiştirmiş olabilir misiniz?
Bendeki çalışan dosyanızı paylaşıyorum.

 

[baykan_m]

Gönderdiğiniz örnek dosya bende açık. Ve dediğiniz gibi bir hata vermiyor. Dosyanızın bir yerlerini değiştirmiş olabilir misiniz?
Bendeki çalışan dosyanızı paylaşıyorum.

Ömer Faruk Bey,

Şimdi bende yanılmış olmayayım diye buraya yüklediğimi indirdim onun üzerinden denedim ancak yine puantaj sayfası boş geliyor.

 

[ÖmerFaruk]

Örnek dosyanız bende çalışıyor. Çalışan halini de ekledim. Sizde de boş geliyor olmaması lazım.

 

[baykan_m]

Ömer Faruk Bey,

Çok ilginç ama şimdi de devamsızlık sayfası boş geliyor. Sizin eklediğinizi indirdim. Neden olabilir, benim excel de mi problem var acaba? Yada uyuşmazlık felan olabilir mi? Benim Excel 2021.

 

[ÖmerFaruk]

Uyuşmazlık olamaz. Nerede hata yapıyorsunuz buradan bilmem imknasız. Ve aslında nasıl bir hata yaptığınızı da anlamış değilim. Kodları hata olmasın diye Sayfa isimleriyle beraber oluşturdum.
Kodları F8 ile adımlayarak belki nerede hata yaptığınızı bulabilirsiniz. Ama belki.

 

[baykan_m]

Uyuşmazlık olamaz. Nerede hata yapıyorsunuz buradan bilmem imknasız. Ve aslında nasıl bir hata yaptığınızı da anlamış değilim. Kodları hata olmasın diye Sayfa isimleriyle beraber oluşturdum.
Kodları F8 ile adımlayarak belki nerede hata yaptığınızı bulabilirsiniz. Ama belki.

Çok teşekkür ederim Ömer Faruk Bey. Dediğiniz gibi ben hata yapmışım çok özür dilerim. Kodu tek gibi düşünüp sadece birini çalıştırıyormuşum. Adımlayınca fark ettim. Elinize sağlık muhteşem olmuş.

Kolay gelsin

 

[ÖmerFaruk]

Özüre gerek yok.
İşiniz görüldüyse konu benim için tamamdır.
Kolay gelsin