• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

arge merkezi içeride kalınan sürelerin toplamı hk.

iç olan giriş saati dış olan çıkış saati olmalı. son birde kart numarası ile isimleri eşleştirme yapabilirmiyiz. mesela bazen sadece kart numarası geliyor rapor aldığımda bunun yanına isimi hangi kart numarası kimde ise otomatik atabilirmi
 
Öncelikle eski dosyadaki sonuçlar sayfasını kopya olarak yeni dosyanıza taşıyın (iki dosyada açıkken sayfa adına sağ tık, taşı veya kopyala, üstten yeni dosyayı seçip alttan kopya oluşturu işaretleyerek işlemi tamamlayın).

Makro olarak aşağıdaki kodları yeni dosyanızda bir modüle kopyalayıp deneyin:

PHP: 
Sub argeciler()
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("sonuçlar")
    son1 = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "A").End(3).Row)
    son2 = WorksheetFunction.Max(3, s2.Cells(Rows.Count, "A").End(3).Row, s2.Cells(Rows.Count, "G").End(3).Row)

    s1.Sort.SortFields.Clear
    s1.Sort.SortFields.Add Key:=Range("B2:B" & son1) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    s1.Sort.SortFields.Add Key:=Range("A2:A" & son1) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With s1.Sort
        .SetRange Range("A1:I" & son1)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    sonB = s1.Cells(Rows.Count, "B").End(3).Row
    s2.Range("A3:M" & son2) = ""
    For i = 2 To sonB
        If s1.Cells(i, "I") = "İÇ" Then
            yeni = WorksheetFunction.Max(s2.Cells(Rows.Count, "A").End(3).Row + 1, s2.Cells(Rows.Count, "G").End(3).Row + 1)
            s2.Cells(yeni, "A") = s1.Cells(i, "A")
            s2.Cells(yeni, "B") = s1.Cells(i, "C")
            s2.Cells(yeni, "C") = s1.Cells(i, "D")
            s2.Cells(yeni, "D") = s1.Cells(i, "E")
            s2.Cells(yeni, "E") = s1.Cells(i, "F")
        Else
            giris = s2.Cells(Rows.Count, "A").End(3).Row
            cikis = s2.Cells(Rows.Count, "G").End(3).Row
            If cikis >= giris Then giris = cikis + 1
'            If s2.Cells(giris, "B") <> s1.Cells(i, "C") Then giris = giris + 1
            s2.Cells(giris, "G") = s1.Cells(i, "A")
            s2.Cells(giris, "H") = s1.Cells(i, "C")
            s2.Cells(giris, "I") = s1.Cells(i, "D")
            s2.Cells(giris, "J") = s1.Cells(i, "E")
            s2.Cells(giris, "K") = s1.Cells(i, "F")
        End If
                
    Next
    sonA = s2.Cells(Rows.Count, "A").End(3).Row
    sonG = s2.Cells(Rows.Count, "G").End(3).Row
    For j = 3 To WorksheetFunction.Max(3, sonA, sonG)
        If s2.Cells(j, "B") = s2.Cells(j, "H") Then
            s2.Cells(j, "M").FormulaR1C1 = "=RC[-6]-RC[-12]"
        ElseIf s2.Cells(j, "A") = "" Then
            s2.Cells(j, "M") = "Giriş yok"
        ElseIf s2.Cells(j, "G") = "" Then
            s2.Cells(j, "M") = "Çıkış Yok"
        Else
            s2.Cells(j, "M") = "İsimler Farklı"
        End If
    Next
    [P:Q] = ""
    s2.[P1] = "Adı Soyadı"
    s2.[Q1] = "Toplam İçerde Kalma Süresi"
    [P1:Q1].Font.Bold = True
    s2.Range("B3:B" & giris).Copy s2.[P2]
    Application.CutCopyMode = False
    s2.Range("$P$1:$P$" & giris).RemoveDuplicates Columns:=1, Header:=xlYes
    sonP = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "P").End(3).Row)
    For j = 2 To sonP
        s2.Cells(j, "Q") = WorksheetFunction.SumIf(s2.Range("B2:B" & giris), s2.Cells(j, "P"), s2.Range("M2:M" & giris))
    Next
    For p = sonP To 2 Step -1
        If s2.Cells(p, "P") = "" Then
            s2.Range("P" & p & ":Q" & p).Delete shift:=xlUp
        End If
    Next
    Range("Q2:Q" & sonP).NumberFormat = "[$-x-systime]h:mm:ss AM/PM"
    Range("P2:Q" & sonP).VerticalAlignment = xlCenter
    Range("Q2:Q" & sonP).HorizontalAlignment = xlCenter
    Range("1:19").EntireColumn.AutoFit
End Sub
 
İsim ekleme işlemi için kodu güncelledim:

PHP: 
Sub argeciler()
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("sonuçlar")
    son1 = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "A").End(3).Row)
    son2 = WorksheetFunction.Max(3, s2.Cells(Rows.Count, "A").End(3).Row, s2.Cells(Rows.Count, "G").End(3).Row)

    s1.Sort.SortFields.Clear
    s1.Sort.SortFields.Add Key:=Range("B2:B" & son1) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    s1.Sort.SortFields.Add Key:=Range("A2:A" & son1) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
    With s1.Sort
        .SetRange Range("A1:I" & son1)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    sonB = s1.Cells(Rows.Count, "B").End(3).Row
    For k = 2 To sonB
        If s1.Cells(k, "C") = "" Then
            For m = 2 To sonB
                If s1.Cells(m, "B") = s1.Cells(k, "B") And s1.Cells(m, "C") <> "" Then
                    s1.Cells(k, "C") = s1.Cells(m, "C")
                    m = sonB
                End If
            Next
        End If
    Next
    s2.Range("A3:M" & son2) = ""
    For i = 2 To sonB
        If s1.Cells(i, "I") = "İÇ" Then
            yeni = WorksheetFunction.Max(s2.Cells(Rows.Count, "A").End(3).Row + 1, s2.Cells(Rows.Count, "G").End(3).Row + 1)
            s2.Cells(yeni, "A") = s1.Cells(i, "A")
            s2.Cells(yeni, "B") = s1.Cells(i, "C")
            s2.Cells(yeni, "C") = s1.Cells(i, "D")
            s2.Cells(yeni, "D") = s1.Cells(i, "E")
            s2.Cells(yeni, "E") = s1.Cells(i, "F")
        Else
            giris = s2.Cells(Rows.Count, "A").End(3).Row
            cikis = s2.Cells(Rows.Count, "G").End(3).Row
            If cikis >= giris Then giris = cikis + 1
'            If s2.Cells(giris, "B") <> s1.Cells(i, "C") Then giris = giris + 1
            s2.Cells(giris, "G") = s1.Cells(i, "A")
            s2.Cells(giris, "H") = s1.Cells(i, "C")
            s2.Cells(giris, "I") = s1.Cells(i, "D")
            s2.Cells(giris, "J") = s1.Cells(i, "E")
            s2.Cells(giris, "K") = s1.Cells(i, "F")
        End If
                
    Next
    sonA = s2.Cells(Rows.Count, "A").End(3).Row
    sonG = s2.Cells(Rows.Count, "G").End(3).Row
    For j = 3 To WorksheetFunction.Max(3, sonA, sonG)
        If s2.Cells(j, "B") = s2.Cells(j, "H") Then
            s2.Cells(j, "M").FormulaR1C1 = "=RC[-6]-RC[-12]"
        ElseIf s2.Cells(j, "A") = "" Then
            s2.Cells(j, "M") = "Giriş yok"
        ElseIf s2.Cells(j, "G") = "" Then
            s2.Cells(j, "M") = "Çıkış Yok"
        Else
            s2.Cells(j, "M") = "İsimler Farklı"
        End If
    Next
    [P:Q] = ""
    s2.[P1] = "Adı Soyadı"
    s2.[Q1] = "Toplam İçerde Kalma Süresi"
    [P1:Q1].Font.Bold = True
    s2.Range("B3:B" & giris).Copy s2.[P2]
    Application.CutCopyMode = False
    s2.Range("$P$1:$P$" & giris).RemoveDuplicates Columns:=1, Header:=xlYes
    sonP = WorksheetFunction.Max(2, s2.Cells(Rows.Count, "P").End(3).Row)
    For j = 2 To sonP
        s2.Cells(j, "Q") = WorksheetFunction.SumIf(s2.Range("B2:B" & giris), s2.Cells(j, "P"), s2.Range("M2:M" & giris))
    Next
    For p = sonP To 2 Step -1
        If s2.Cells(p, "P") = "" Then
            s2.Range("P" & p & ":Q" & p).Delete shift:=xlUp
        End If
    Next
    Range("Q2:Q" & sonP).NumberFormat = "[$-x-systime]h:mm:ss AM/PM"
    Range("P2:Q" & sonP).VerticalAlignment = xlCenter
    Range("Q2:Q" & sonP).HorizontalAlignment = xlCenter
    Range("1:19").EntireColumn.AutoFit
End Sub
 
çok tesekkur ederim emeğinize sağlık çok büyük bir dertti benim için :))
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst