koşula göre veri alma

emrebengul · 2 Kasım 2023

merhaba arkadaşlar
Sayfalardaki verileri koşul göre almak istiyorum.
Örneğin 2 adet 40 dakika var bunu otomatik olarak 2 satıra yazmak istiyorum. Veya 3 adet 30 dakika olduğunda olduğunda A4 hücresine 30 dakika yazıp altına verileri alsın. Şimdiden çok teşekkür ederim.

emrebengul · 3 Kasım 2023

konu günceldir. Destek olma şansınız var m?

Korhan Ayhan · 3 Kasım 2023

Deneyiniz.

C++:

Option Explicit

Sub My_Report()
    Dim My_Connection As Object, My_Recordset As Object, My_Query As String
   
    Application.ScreenUpdating = False

    Set My_Connection = CreateObject("AdoDB.Connection")
    Set My_Recordset = CreateObject("AdoDB.Recordset")

    Sheets("rapor").Range("A2:E" & Rows.Count).ClearContents
   
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""

    My_Query = "Select F1,F2,F3,F4 From [devamsızlık$A2:G] Where F5 = '" & Sheets("rapor").Range("A1").Value & "' " & _
               "Union " & _
               "Select F1,F2,F3,F4 From [devamsızlık$A2:G] Where F6 = '" & Sheets("rapor").Range("A1").Value & "'"
   
    My_Recordset.Open My_Query, My_Connection, 1, 1
   
    Sheets("rapor").Range("A2").CopyFromRecordset My_Recordset
    Sheets("rapor").Columns.AutoFit
 
    My_Recordset.Close
    My_Connection.Close

    Set My_Recordset = Nothing
    Set My_Connection = Nothing

    MsgBox "İşleminiz tamamlanmıştır"
End Sub

ÖmerFaruk · 3 Kasım 2023

Korhan bey cevaplamış ancak hazır yazmışken alternatif olsun.

Unutulmaması gereken bir husus, kodlarda Early Binding metodu uyguladığım için VBA / Tools / Reference kısmında Microsoft Scripting Runtime seçili olmalııdr.

C++:

Sub Liste()
    Dim dict As New Scripting.Dictionary, subdict As New Scripting.Dictionary
    Dim i As Integer, k As Integer, Say As Integer, Anahtar, Veri
    Veri = Range("A1").CurrentRegion.Value
    For i = 2 To UBound(Veri, 1)
        If Veri(i, 5) <> "" Then
            Anahtar = Veri(i, 5)
        Else
            Anahtar = Veri(i, 6)
        End If
        If Not dict.Exists(Anahtar) Then
            dict.Add Anahtar, i
            Say = Say + 2
        Else
            dict(Anahtar) = dict(Anahtar) & "-" & i
            Say = Say + 1
        End If
    Next i
    ReDim Liste(1 To Say, 1 To 5)
    Say = 0
    For i = 1 To dict.Count
        Say = Say + 1
        Liste(Say, 1) = dict.Keys(i - 1)
        Liste(Say, 3) = "CİNSİYET"
        Liste(Say, 4) = "ORTAM MOLA"
        Liste(Say, 5) = "TOPLAM"
        Yaz = Split(dict.Items(i - 1), "-")
        For k = 1 To UBound(Yaz) + 1
            Say = Say + 1
            For x = 1 To 4
                Liste(Say, x) = Veri(Yaz(k - 1), x)
            Next x
        Next k
    Next i
    Worksheets("rapor").Range("A:E").Clear
    Worksheets("rapor").Range("A1").Resize(UBound(Liste, 1), UBound(Liste, 2)) = Liste
End Sub

emrebengul · 3 Kasım 2023

Öncelikle çok teşekkür ederim. Pek, buı dosyaya uyarlama şansımız var mı bunu üstadlar?
Uyarlamaya çalıştım fakat hata veriyor anlamadım.

ÖmerFaruk · 3 Kasım 2023

Kodları boş bir modüle ekleyin.
Sayafdaki düğmeye bu makroyu atayın.

C++:

Sub Liste()
    Dim dict As New Scripting.Dictionary, subdict As New Scripting.Dictionary
    Dim i As Integer, k As Integer, Say As Integer, Anahtar, Veri
    Veri = Range("A1").CurrentRegion.Value
    For i = 2 To UBound(Veri, 1)
        'If Veri(i, 14) <> "" Then
            Anahtar = Veri(i, 14)
        'Else
            'Anahtar = Veri(i, 6)
        'End If
        If Not dict.Exists(Anahtar) Then
            dict.Add Anahtar, i
            Say = Say + 2
        Else
            dict(Anahtar) = dict(Anahtar) & "-" & i
            Say = Say + 1
        End If
    Next i
    ReDim Liste(1 To Say, 1 To 5)
    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) = "SHİFT" '"ORTAM MOLA"
        Liste(Say, 5) = "TOPLAM"
        Yaz = Split(dict.Items(i - 1), "-")
        For k = 1 To UBound(Yaz) + 1
            Say = Say + 1
            For x = 1 To 4
                Liste(Say, x) = Veri(Yaz(k - 1), x + 2)
            Next x
        Next k
    Next i
    'Worksheets("rapor").Range("A:E").Clear
    'Worksheets("rapor").Range("A1").Resize(UBound(Liste, 1), UBound(Liste, 2)) = Liste
    Worksheets("rapor1").Range("A:E").Clear
    Worksheets("rapor1").Range("A1").Resize(UBound(Liste, 1), UBound(Liste, 2)) = Liste
End Sub

emrebengul · 3 Kasım 2023

hocam çok teşekkür ederim sağ olun

emrebengul · 7 Kasım 2023

hocam belki çok oldu ama şöyle yapma ihtimalimiz var mı? yaptığımız kod çalışmasında altına 2 satır boşluk ve her bir bölüm için o satırları boyama. Örnek dosya ektedir. Teşekkür ederim

ÖmerFaruk · 7 Kasım 2023

C-D-E sütun başlıklarınız doğru mudur? 2 tane Gece var. Bir daha düzeltmekle uğraşmayalım diye soruyorum. İlk çözümde 5. ve 6. sütunlarda bir işlem yapmamıştım, başlıkları boş geçmiştim.
Ayrıca toplamanın mantığını da söylemelisiniz. Sayısal olmayan ifadeler var. Bunlar toplama nasıl girecek?

emrebengul · 7 Kasım 2023

evet C-D-E doğrudur. Tabloda Mazaret ve Gece sütununun altında yazanları satır dolu ise aşağıya kaç satır dolu olduğunu yazsın. Fabrikada kaç adet ENJEKSİYON varsa o toplamın altına gece ve mazeretten çıkarıp yazsın istioyurm.

emrebengul · 7 Kasım 2023

üstadım doğru anlatmışımdır inşAllah

emrebengul · 8 Kasım 2023

Konu günceldir

ÖmerFaruk · 8 Kasım 2023

Rapor1 sayfasında sütun başlıkları ile YAPMAKİSTEDİĞİM sayfanızda sütun başlıkları arasında fark var. Farkını ve nasıl oluştuğunu anlamadım.
Toplama alırken de dolu satırları saysın diyorsunuz. Ama sayısal ifade neden kullanıyoruz o durumda. Fabrika sayfasındaki E sütunudna sadece P ya da 1 mi yazacak? 2 olma ihtimali yok mu? Ne yazarsa yazsın toplarken dollu-boş olmasına mı bakacağız?
Aynı soru Fabrika sayfası F sütunu için de geçerli.
Ben tablonuzu anlayamadığım için cevaplamakta terettüt ediyorum.

Şöyle ilerlesek daha iyi olacak.
3-4 satır değil de, her hitimali içeren 15-20 satırlık bir tablo oluşturup, sonuçta görmek istedğiniz rapor sayfasını manuel doldurup paylaşabilirsiniz.

emrebengul · 8 Kasım 2023

ömer bey şöyle anlatayım
sizin yazdığınız kodda sadece şurayı değiştirdim
ReDim Liste(1 To Say, 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"
geri kalan yer aynı.
Ne yazarsa yazsın toplarken dollu-boş olmasına bakacağız. yani dolu say fonksiyonu gibi düşünebiliriz.
son olarak ise; örneğin enjeksiyon için söyleyeyim fabrika sayfasında bölüm ismi sütununda kaç adet enjeksiyon varsa, gece ve mazaret adetinden çıkarıp topla sütunun yazsın. Çünkü veri her seferinde farklı geliyor ondan dolayı böyle bir yola başvurdum.

emrebengul · 8 Kasım 2023

anlatabildim mi Ömer Faruk Bey?

ÖmerFaruk · 8 Kasım 2023

Tekrar belirteyim.

Şöyle ilerlesek daha iyi olacak.
3-4 satır değil de, her hitimali içeren 15-20 satırlık bir tablo oluşturup, sonuçta görmek istedğiniz rapor sayfasını manuel doldurup paylaşabilirsiniz.

emrebengul · 9 Kasım 2023

Ömer Faruk Bey merhaba;

Eskisine göre yapma ihtimalimiz var mı? Gece Gündüzü kaldırdım shift olrak yaptım. fonksiyonlar ilede belirttim. Desteğiniz için teşekkür ederim.

emrebengul · 9 Kasım 2023

inşAllah olmuştur bu sefer anlatabilmişimdir.

emrebengul · 10 Kasım 2023

Konu günceldir.

ÖmerFaruk · 11 Kasım 2023

Aşağıdaki kodları kullanabilirsiniz.
Mevcut YAPMAKİSTEDİĞİM sayfanızdaki sonuçlar FABRİKA sayfasındaki tablonuzla çelişiyordu. Bu sebeple ne istediğinizi anlamakta zorlandım. Umarım doğru anlamışımdır.

C++:

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 5)
    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) = "SHİFT" '"ORTAM MOLA"
        Liste(Say, 5) = "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 = 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) = UBound(Yaz) + 1 - Topla1 - Topla2
        Say = Say + 1
    Next i
    Worksheets("rapor1").Range("A:E").ClearContents
    Worksheets("rapor1").Range("A1").Resize(Say, 5) = Liste
End Sub

koşula göre veri alma

emrebengul

Ekli dosyalar

emrebengul

Korhan Ayhan

Administrator

ÖmerFaruk

Destek Ekibi

emrebengul

Ekli dosyalar

ÖmerFaruk

Destek Ekibi

emrebengul

emrebengul

Ekli dosyalar

ÖmerFaruk

Destek Ekibi

emrebengul

emrebengul

emrebengul

ÖmerFaruk

Destek Ekibi

emrebengul

emrebengul

ÖmerFaruk

Destek Ekibi

emrebengul

Ekli dosyalar

emrebengul

emrebengul

ÖmerFaruk

Destek Ekibi