• DİKKAT

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

Iki koşullu sayma

O

onurcan1979

Katılım
29 Mayıs 2010
Mesajlar
186
Excel Vers. ve Dili
2003 tr
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

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

Orion1' Alıntı:
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
Genişletmek için tıkla ...

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
 
onurcan1979' Alıntı:
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
Genişletmek için tıkla ...
faal şekilde nasıl ! anlamadım.
Diğer sütunlarda aynı yöntemle sayılabilir.:cool:
 
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.
 
Orion1' Alıntı:
faal şekilde nasıl ! anlamadım.
Diğer sütunlarda aynı yöntemle sayılabilir.:cool:
Genişletmek için tıkla ...

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?
 
onurcan1979' Alıntı:
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?
Genişletmek için tıkla ...
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

Orion1' Alıntı:
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
Genişletmek için tıkla ...

Emeğine sağlık teşekkür ederim tam istediğim gibi olmuş
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst