Iki koşullu sayma

[onurcan1979]

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

 

[Orion1]

Dosyanız ektedir.

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

 

[onurcan1979]

Dosyanız ektedir.

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]

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.

 

[Korhan Ayhan]

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.

=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.

=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.

=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]

faal şekilde nasıl ! anlamadım.
Diğer sütunlarda aynı yöntemle sayılabilir.

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]

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.
makronun kullanışı

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

 

[onurcan1979]

Tıkla butonunda nasıl kullanacağınız şeklinde açıklama yazdım.örnek vererek.
istediğiniz miktarda bu fonksiyonu yazarak yanyana listeleyebilirsiniz.
makronun kullanışı

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ş