Firma Bazında Ürün Ödeme Bilgilerini Görme

[TASADAM366]

Değerli arkadaşlarım,size gönderdiğim örnekte 100 kalem ürün var.Ve 27 farklı firma var.
Bu 100 kalem ürünlerden peşin ödeme yaparak alan firmaların ürünle ilgili hücresine NAKİT,taksitle almış ise ilgili hücresine TAKSİT yazılmıştır.
Şimdi benim istediğim şu;
Her ürün için geçerli olmak üzere,atanacak bir makro yardımıyla;
1.Ürünü kaç firma peşin almışsa D sutununda ilgili ürünün bulunduğu satırla kesisen hücresine firma sayısını yazsın.(d4,d5,...d100)
2.Ürünü hangi firma/firmalar peşin almışsa E sutununda ilgili ürünün bulunduğu satırla kesisen hücresine bu firmaların adını/adlarını yazsın.İsimler arasına önünde ve sonunda boşluk olan virgülde eklensin.(E4,E5,...E100)
3.Ürünü kaç firma taksitle almışsa F sutununda ilgili ürünün bulunduğu satırla kesisen hücresine firma sayısını yazsın.(F4,F5,...F100)
4.Ürünü hangi firma/firmalar taksitle almışsa G sutununda ilgili ürünün bulunduğu satırla kesisen hücresine bu firmaların adını/adlarını yazsın.İsimler arasına önünde ve sonunda boşluk olan virgülde eklensin.(G4,G5,...G100)

İlginiz ve yardımlarınız için şimdiden teşekkür ederim.Saygılarımla

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu deneyiniz.

Option Explicit

Sub FİRMA_ANALİZİ()
    Dim X As Long, Y As Integer
    
    Application.ScreenUpdating = False
    
    Range("D4:G" & Rows.Count).ClearContents
    
    For X = 4 To Cells(Rows.Count, "C").End(3).Row
        Cells(X, "D") = WorksheetFunction.CountIf(Range("H" & X & ":" & Cells(X, Columns.Count).Address(0, 0)), "NAKİT")
        Cells(X, "F") = WorksheetFunction.CountIf(Range("H" & X & ":" & Cells(X, Columns.Count).Address(0, 0)), "TAKSİT")
        
        For Y = 8 To Cells(3, Columns.Count).End(1).Column
            If Cells(X, Y) = "NAKİT" Then
                Cells(X, "E") = IIf(Cells(X, "E") = "", Cells(3, Y), Cells(X, "E") & ", " & Cells(3, Y))
            ElseIf Cells(X, Y) = "TAKSİT" Then
                Cells(X, "G") = IIf(Cells(X, "G") = "", Cells(3, Y), Cells(X, "G") & ", " & Cells(3, Y))
            End If
        Next
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[asi_kral]

Merhaba
Alternatif Olsun.

Option Explicit
Sub say_yaz()
Dim SAT As Long, SÜT As Long
Dim NAK1 As Long, NAK2 As String
Dim TAK1 As Long, TAK2 As String
Application.ScreenUpdating = False
Range("D4:G" & Cells(Rows.Count, "A").End(xlUp).Row).ClearContents
For SAT = 4 To Cells(Rows.Count, "A").End(xlUp).Row
NAK1 = 0: NAK2 = "": TAK1 = 0: TAK2 = ""
For SÜT = 8 To Cells(3, Columns.Count).End(xlToLeft).Column
If Cells(SAT, SÜT) <> Empty Then
If Cells(SAT, SÜT) = "NAKİT" Then
NAK1 = NAK1 + 1
If NAK2 = "" Then
NAK2 = Cells(3, SÜT)
Else
NAK2 = NAK2 & " , " & Cells(3, SÜT)
End If
ElseIf Cells(SAT, SÜT) = "TAKSİT" Then
TAK1 = TAK1 + 1
If TAK2 = "" Then
TAK2 = Cells(3, SÜT)
Else
TAK2 = TAK2 & " , " & Cells(3, SÜT)
End If
End If
End If
Next
Cells(SAT, "D") = NAK1: Cells(SAT, "E") = NAK2
Cells(SAT, "F") = TAK1: Cells(SAT, "G") = TAK2
Next
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation
End Sub

Bu kod işinizi görür sanırım.

 

[Huseyinkis]

Ekli, kodları denermisiniz.

Alternatifin Alternatifi Olsun

Sub TEst()
For i = 4 To Cells(Rows.Count, 2).End(3).Row
For x = 8 To Cells(i, Columns.Count).End(1).Column
If Cells(i, x).Value = "NAKİT" Then
Nkt = Nkt & " , " & Cells(3, x).Value
ElseIf Cells(i, x).Value = "TAKSİT" Then
Tks = Tks & " , " & Cells(3, x).Value
End If
Next
Cells(i, 4).Value = WorksheetFunction.CountIf(Range("H" & i & ":CA" & i), "NAKİT")
Cells(i, 5).Value = Nkt
Cells(i, 6).Value = WorksheetFunction.CountIf(Range("H" & i & ":CA" & i), "TAKSİT")
Cells(i, 7).Value = Tks
Nkt = ""
Tks = ""
Next
End Sub

 

[TASADAM366]

İnanın nasıl teşekkür edeceğimi bilmiyorum.Körün istediği bir göz Allah verdi iki göz hesabı oldu benimkisi.Her 3 formülde sorunsuz çalıştı.Her 3 formülü de kaydettim.Ve Korhan beyin makrosunu çalışmama ekledim.Ellerinize sağlık.Hepinize ayrı ayrı teşekkür ederim.
Tek ufak bir isteğim var.
Örnekte görünmüyor.Ama asıl çalışmam da var.
104. ve 105. satırlara ait E hücresinden H hücresine kadar birleştirdim.Ve oraya bir açıklama girdim.Bunu yapınca makro çalıştığında şu hatayı veriyor.
Run-time error:1004
Birleştirilmiş bir hücrenin parçası değiştirilemez.
Bunu aşmak için(Korhan bey sizinkinde)
Range("E4:H" & Rows.Count).ClearContents
satırını
Range("E4:H103" & Rows.Count).ClearContents
yapıyorum bu sefer makro
Method 'Range' of object_Global' failed
hatası veriyor.
Ben bu makro kodunda nereyi düzenlersem belli bir aralığa kadar makronun etkin olmasını sağlarım?
Kısaca makro örneğime göre şunu yapsın:
H4-AH103 aralığında arama yapsın.
ve D4-G103 aralığına ilk mesajımda belirttiğim değerlerini getirsin.Bu alanın dışına taşmasın.
Saygılarımla

 

[Korhan Ayhan]

Merhaba,

Kırmızı bölümü silip deneyin.

Range("E4:H103"[COLOR="Red"] & Rows.Count[/COLOR]).ClearContents

 

[TASADAM366]

Korhan bey teşekkür ederim.Dediğinizi yaptım.Ve işe yaradı.Saygılarımla