Iki koşullu sayma

onurcan1979

Altın Üye
Katılım
29 Mayıs 2010
Mesajlar
186
Excel Vers. ve Dili
2003 tr
Altın Üyelik Bitiş Tarihi
23/10/2025
Merhaba arkadaşlar benim sorunum personel kıyafet listesi ile ilgili bu listede bulunan gömlek, pantolon ve ayakkabıları saydırmak istiyorum fakat bay ve bayan olarak mesela bay 38 numara ayakkabı giyorsa onu bay kımda saymasını bayan 38 giyorsa bayan kısmında samasını istiyorum bu konuda yardımcı olursanız çok sevinirim örnek liste ektedir bunu maro olarak veya excell formülü olarak yapabilirmiyiz makro olursa daha iyi olur ama excell formülüde işimi görür. şimdiden teşekkürler
 

Ekli dosyalar

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,248
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
Dosyanız ektedir.:cool:

Kod:
Option Base 1
Sub ayakkabi_carik_say()
Dim z As Object, i As Long, list(), n As Long, sat As Long
Sheets("KIYAFET").Select
sat = Cells(65536, "B").End(xlUp).Row
Range("G2:H65536").ClearContents
If sat < 2 Then Exit Sub
Application.ScreenUpdating = False
list = Range("B2:C" & sat).Value
ReDim myarr(1 To 3, 1 To sat)
Set z = CreateObject("scripting.dictionary")
For i = 1 To UBound(list)
    deg = list(i, 1) & "-" & list(i, 2)
    If Not z.exists(deg) Then
        n = n + 1
        z.Add deg, n
        myarr(1, z.Item(deg)) = list(i, 1)
        myarr(2, z.Item(deg)) = list(i, 2)
    End If
    myarr(3, z.Item(deg)) = myarr(3, z.Item(deg)) + 1
Next i
Erase list: Set z = Nothing
ReDim Preserve myarr(1 To 3, 1 To n)
Range("G2").Resize(n, 3) = Application.Transpose(myarr)
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbOKOnly + vbInformation, "B İ T T İ"
End Sub
 

Ekli dosyalar

onurcan1979

Altın Üye
Katılım
29 Mayıs 2010
Mesajlar
186
Excel Vers. ve Dili
2003 tr
Altın Üyelik Bitiş Tarihi
23/10/2025
Dosyanız ektedir.:cool:

Kod:
Option Base 1
Sub ayakkabi_carik_say()
Dim z As Object, i As Long, list(), n As Long, sat As Long
Sheets("KIYAFET").Select
sat = Cells(65536, "B").End(xlUp).Row
Range("G2:H65536").ClearContents
If sat < 2 Then Exit Sub
Application.ScreenUpdating = False
list = Range("B2:C" & sat).Value
ReDim myarr(1 To 3, 1 To sat)
Set z = CreateObject("scripting.dictionary")
For i = 1 To UBound(list)
    deg = list(i, 1) & "-" & list(i, 2)
    If Not z.exists(deg) Then
        n = n + 1
        z.Add deg, n
        myarr(1, z.Item(deg)) = list(i, 1)
        myarr(2, z.Item(deg)) = list(i, 2)
    End If
    myarr(3, z.Item(deg)) = myarr(3, z.Item(deg)) + 1
Next i
Erase list: Set z = Nothing
ReDim Preserve myarr(1 To 3, 1 To n)
Range("G2").Resize(n, 3) = Application.Transpose(myarr)
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbOKOnly + vbInformation, "B İ T T İ"
End Sub
hocam eline sağlık güzel olmuş fakat bunu tıklayarak değilde faal şekilde saymasını sağlaya bilirmiyiz bide diğer verileri nasıl saydıra bilirim
 

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,248
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
hocam eline sağlık güzel olmuş fakat bunu tıklayarak değilde faal şekilde saymasını sağlaya bilirmiyiz bide diğer verileri nasıl saydıra bilirim
faal şekilde nasıl ! anlamadım.
Diğer sütunlarda aynı yöntemle sayılabilir.:cool:
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,776
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Merhaba,

İstediğiniz sonuca TOPLA.ÇARPIM formülü ile rahatlıkla ulaşabilirsiniz.

B2 hücresine aşağıdaki formülü uygulayın. C sütununa ve alt hücrelere sürükleyin.

Kod:
=TOPLA.ÇARPIM((KIYAFET!$E$2:$E$1000=$A2)*(KIYAFET!$B$2:$B$1000=B$1))
E2 hücresine aşağıdaki formülü uygulayın. F sütununa ve alt hücrelere sürükleyin.

Kod:
=TOPLA.ÇARPIM((KIYAFET!$D$2:$D$1000=$D2)*(KIYAFET!$B$2:$B$1000=E$1))
H2 hücresine aşağıdaki formülü uygulayın. I sütununa ve alt hücrelere sürükleyin.

Kod:
=TOPLA.ÇARPIM((KIYAFET!$C$2:$C$1000=$G2)*(KIYAFET!$B$2:$B$1000=H$1))
Hesaplama yönteminiz manuelde olduğu için sonucu görmek istediğinizde F9 tuşuna basmanız yeterlidir.
 

onurcan1979

Altın Üye
Katılım
29 Mayıs 2010
Mesajlar
186
Excel Vers. ve Dili
2003 tr
Altın Üyelik Bitiş Tarihi
23/10/2025
faal şekilde nasıl ! anlamadım.
Diğer sütunlarda aynı yöntemle sayılabilir.:cool:
Tıklama yapmadan otamatik şekilde yapıla bilirmi gerçi ben otomatik kısmını hallettim ama sadece diğer verileri saydıramadım gömlek - pantolonu onu nasıl yapa bilirim bu konuda yardımcı olursanız?
 

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,248
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
Tıklama yapmadan otamatik şekilde yapıla bilirmi gerçi ben otomatik kısmını hallettim ama sadece diğer verileri saydıramadım gömlek - pantolonu onu nasıl yapa bilirim bu konuda yardımcı olursanız?
Tıkla butonunda nasıl kullanacağınız şeklinde açıklama yazdım.örnek vererek.
istediğiniz miktarda bu fonksiyonu yazarak yanyana listeleyebilirsiniz.:cool:
makronun kullanışı

Kod:
Sub Resim1_Tıklat()
Call ayakkabi_carik_say(3, 7)
'call ayakkabı_carik_say(3ncü sütundaki verileri topla_say,
'7nci sütundan itibaren verileri aktar
Call ayakkabi_carik_say(4, 11)
Call ayakkabi_carik_say(5, 15)
MsgBox "İşlem Tamamlandı", vbOKOnly + vbInformation, "B İ T T İ"
End Sub


Option Base 1
Sub ayakkabi_carik_say(ByVal sut1 As Integer, ByVal sut2 As Integer)
Dim z As Object, i As Long, n As Long, sat As Long, myarr()
Sheets("KIYAFET").Select
sat = Cells(65536, "B").End(xlUp).Row
Range(Cells(2, sut2), Cells(65536, sut2 + 2)).ClearContents
If sat < 2 Then Exit Sub
n = 0
Application.ScreenUpdating = False
ReDim myarr(1 To 3, 1 To sat)
Set z = CreateObject("scripting.dictionary")
For i = 2 To sat
    deg = Cells(i, 2).Value & "-" & Cells(i, sut1).Value
    If Not z.exists(deg) Then
        n = n + 1
        z.Add deg, n
        myarr(1, z.Item(deg)) = Cells(i, 2).Value
        myarr(2, z.Item(deg)) = Cells(i, sut1).Value
    End If
    myarr(3, z.Item(deg)) = myarr(3, z.Item(deg)) + 1
Next i
Set z = Nothing
ReDim Preserve myarr(1 To 3, 1 To n)
Cells(2, sut2 + 1).Resize(n, 3) = Application.Transpose(myarr)
Cells(1, sut2 + 1).Value = Cells(1, 2)
Cells(1, sut2 + 2).Value = Cells(1, sut1)
Cells(1, sut2 + 3).Value = "TOPLAM ADET"
Erase myarr
Application.ScreenUpdating = True
End Sub
 

Ekli dosyalar

onurcan1979

Altın Üye
Katılım
29 Mayıs 2010
Mesajlar
186
Excel Vers. ve Dili
2003 tr
Altın Üyelik Bitiş Tarihi
23/10/2025
Tıkla butonunda nasıl kullanacağınız şeklinde açıklama yazdım.örnek vererek.
istediğiniz miktarda bu fonksiyonu yazarak yanyana listeleyebilirsiniz.:cool:
makronun kullanışı

Kod:
Sub Resim1_Tıklat()
Call ayakkabi_carik_say(3, 7)
'call ayakkabı_carik_say(3ncü sütundaki verileri topla_say,
'7nci sütundan itibaren verileri aktar
Call ayakkabi_carik_say(4, 11)
Call ayakkabi_carik_say(5, 15)
MsgBox "İşlem Tamamlandı", vbOKOnly + vbInformation, "B İ T T İ"
End Sub


Option Base 1
Sub ayakkabi_carik_say(ByVal sut1 As Integer, ByVal sut2 As Integer)
Dim z As Object, i As Long, n As Long, sat As Long, myarr()
Sheets("KIYAFET").Select
sat = Cells(65536, "B").End(xlUp).Row
Range(Cells(2, sut2), Cells(65536, sut2 + 2)).ClearContents
If sat < 2 Then Exit Sub
n = 0
Application.ScreenUpdating = False
ReDim myarr(1 To 3, 1 To sat)
Set z = CreateObject("scripting.dictionary")
For i = 2 To sat
    deg = Cells(i, 2).Value & "-" & Cells(i, sut1).Value
    If Not z.exists(deg) Then
        n = n + 1
        z.Add deg, n
        myarr(1, z.Item(deg)) = Cells(i, 2).Value
        myarr(2, z.Item(deg)) = Cells(i, sut1).Value
    End If
    myarr(3, z.Item(deg)) = myarr(3, z.Item(deg)) + 1
Next i
Set z = Nothing
ReDim Preserve myarr(1 To 3, 1 To n)
Cells(2, sut2 + 1).Resize(n, 3) = Application.Transpose(myarr)
Cells(1, sut2 + 1).Value = Cells(1, 2)
Cells(1, sut2 + 2).Value = Cells(1, sut1)
Cells(1, sut2 + 3).Value = "TOPLAM ADET"
Erase myarr
Application.ScreenUpdating = True
End Sub
Emeğine sağlık teşekkür ederim tam istediğim gibi olmuş
 
Üst