koşula göre veri alma

[emrebengul]

teşekkürler Ömer Hocam.

hocam peki tabloyu böyle yapma ihtimalimiz var mı?

 

[ÖmerFaruk]

Sub Düğme2_Tıkla()
 Dim dict As New Scripting.Dictionary, subdict As New Scripting.Dictionary
    Dim i As Integer, k As Integer, Say As Integer, Anahtar, Veri
    Veri = Worksheets("FABRİKA").Range("A1").CurrentRegion.Value
    For i = 2 To UBound(Veri, 1)
        Anahtar = Veri(i, 14)
        If Not dict.Exists(Anahtar) Then
            dict.Add Anahtar, i
        Else
            dict(Anahtar) = dict(Anahtar) & "-" & i
        End If
    Next i
    ReDim Liste(1 To Rows.Count, 1 To 6)
    Say = 0
    For i = 1 To dict.Count
        Say = Say + 1
        Liste(Say, 1) = dict.Keys(i - 1)
        Liste(Say, 4) = "MAZARET" '"CİNSİYET"
        Liste(Say, 5) = "SHİFT" '"ORTAM MOLA"
        Liste(Say, 6) = "TOPLAM"
        Yaz = Split(dict.Items(i - 1), "-")
        Topla1 = 0
        Topla2 = 0
        For k = 1 To UBound(Yaz) + 1
            If Veri(Yaz(k - 1), 5) <> "" Or Veri(Yaz(k - 1), 6) <> "" Then
                Say = Say + 1
                For x = 2 To 5
                    Liste(Say, x) = Veri(Yaz(k - 1), x + 1)
                Next x
                If Liste(Say, 3) <> "" Then Topla1 = Topla1 + 1
                If Liste(Say, 4) <> "" Then Topla2 = Topla2 + 1
            End If
        Next k
        Say = Say + 1
        Liste(Say, 2) = "TOPLAM"
        Liste(Say, 4) = Topla1
        Liste(Say, 5) = Topla2
        Liste(Say, 6) = UBound(Yaz) + 1 - Topla1 - Topla2
        Say = Say + 1
    Next i
    Worksheets("rapor1").Range("A:F").ClearContents
    Worksheets("rapor1").Range("A1").Resize(Say, 6) = Liste
End Sub

 

[emrebengul]

üstadım çok oldum ama tekrar yine teşekkür ederim.
Peki Örneğin ENJEKSİYON ve VİDALI MODÜLü rapora işlemesin
onuniçin destek olur musunuz?

 

[emrebengul]

konu günceldir.

 

[ÖmerFaruk]

Step step ilerlemekten hoşlanmıyorum.
Benden bu kadar.

 

[emrebengul]

Herşey için Teşekkür ediyorum Ömer Faruk Bey. Son isteğim buydu aslında daha bu konu hakkında rahatsız etmeyeceğim söz

 

[emrebengul]

konu günceldir. kusura bakmayın son noktasına geldim.

 

[emrebengul]

yardım eden herkese teşekkür ederim sağ olun. Ömer Bey özellikle size çok teşekkür ederim
Belki birilerinin işine yarayabilir.
kolay gelsin

Sub Düğme1_Tıkla()

      Dim dict As New Scripting.Dictionary
    Dim i As Integer, k As Integer, Say As Integer, Anahtar, Veri, x As Integer
    Dim Liste() As Variant
    Dim Yaz() As String
    Dim Topla1 As Integer, Topla2 As Integer, Topla3 As Integer

    Veri = Worksheets("Sayfa1").Range("A1").CurrentRegion.Value
    For i = 3 To UBound(Veri, 1)
        Anahtar = Veri(i, 14)
        If Anahtar <> "PLANLAMA" And Anahtar <> "YEMEKHANE" And Anahtar <> "İDARİ İŞLER" Then
            If Not dict.Exists(Anahtar) Then
                dict.Add Anahtar, i
            Else
                dict(Anahtar) = dict(Anahtar) & "-" & i
            End If
        End If
    Next i

    ReDim Liste(1 To Rows.Count, 1 To 6)
    Say = 0

    For i = 1 To dict.Count
        Say = Say + 1
        Liste(Say, 1) = dict.Keys(i - 1)
        Liste(Say, 3) = "MAZARET" '"CİNSİYET"
        Liste(Say, 4) = "GECE" '"ORTAM MOLA"
        Liste(Say, 5) = "GÜNDÜZ"
        Liste(Say, 6) = "TOPLAM"
        Yaz = Split(dict.Items(i - 1), "-")
        Topla1 = 0
        Topla2 = 0
        Topla3 = 0

        For k = 1 To UBound(Yaz) + 1
            If Veri(Yaz(k - 1), 5) <> "" Or Veri(Yaz(k - 1), 6) <> "" Then
                Say = Say + 1
                For x = 1 To 4
                    Liste(Say, x) = Veri(Yaz(k - 1), x + 2)
                Next x
                If Liste(Say, 3) <> "" Then Topla1 = Topla1 + 1
                If Liste(Say, 4) <> "" Then Topla2 = Topla2 + 1
            End If
        Next k

        Say = Say + 1
        Liste(Say, 1) = "TOPLAM"
        Liste(Say, 3) = Topla1
        Liste(Say, 4) = Topla2
        Liste(Say, 5) = Topla3
        Liste(Say, 6) = UBound(Yaz) + 1 - Topla1 - Topla2 - Topla3 & " çalışan vardır"

        Say = Say + 1
    Next i

    Worksheets("rapor").Range("A:E").ClearContents
    Worksheets("rapor").Range("A1").Resize(Say, 6) = Liste

    For N = 1 To 4
        Sayfa2.Range("A1:F11" & Cells(Rows.Count, "A").End(3).Row).Borders(N).LineStyle = 1
    Next N
End Sub