• DİKKAT

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

Seçili alanda. Hangisinden kaç tane var?

B

Bora K

Katılım
21 Ocak 2013
Mesajlar
331
Excel Vers. ve Dili
2003 Türkçe
Merhabalar;

Seçili alanımız ( D8:M38 )
Bu alanın içerisinde belirli periyotlarla güncelenecek verilerimiz olacak.
Bu alandaki verileri ilk önce satır bazında sonrasında ise genel toplam
olarak gösterecek makro kodu istemekteyim.

Yardımı dokunacak arkadaşlara şimdiden teşekkür eder
Tüm forum sakinlerine iyi çalışmalar dilerim.

Saygılarımla.
 

Ekli dosyalar

Bora K' Alıntı:
Merhabalar;

Seçili alanımız ( D8:M38 )
Bu alanın içerisinde belirli periyotlarla güncelenecek verilerimiz olacak.
Bu alandaki verileri ilk önce satır bazında sonrasında ise genel toplam
olarak gösterecek makro kodu istemekteyim.

Yardımı dokunacak arkadaşlara şimdiden teşekkür eder
Tüm forum sakinlerine iyi çalışmalar dilerim.

Saygılarımla.
Genişletmek için tıkla ...

eğersayla olabilirmi ?
 

Ekli dosyalar

Merhaba Süleyman bey.
Uğraş vermişsiniz teşekkür ederim.
Lakin formüllerle maalesef olmaz.
Dosyada başkaca kodlarda olacak çünkü.
 
Merhaba, aşağıdaki kodu denermisiniz.
Kod: 
Sub Bora()
    sonsut = Cells(40, Columns.Count).End(xlToLeft).Column
    For s = 16 To sonsut + 1 Step 2
        For r = 8 To 40
            Cells(r, s) = 0
        Next r
    Next s

    For i = 8 To 38
        For j = 4 To 13
            For c = 15 To sonsut Step 2
                If Cells(i, j) = Cells(40, c) Then
                    Cells(i, c + 1) = Cells(i, c + 1) + WorksheetFunction.CountA(Cells(i, j))
                    Cells(40, c + 1) = Cells(40, c + 1) + WorksheetFunction.CountA(Cells(i, j))
                End If
            Next c
        Next j
    Next i
End Sub
 
Merhabalar

Süleyman Bey alakanız için birkez daha teşekkür ederim.

Daha öncede belirttiğim gibi toplama yapılacak alanı ben başka bir kod yardımı ile
kopmle temizle yapıyorum/yapmak zorundayım. Saydırdığımız verilerde yine başka sayfadan
kod yardımı ile geliyor. Velhasılı durum şu;

Toplam alır iken 40. satıra sayılacak veri isimlerini elle girmeden kod çalışmıyor.
Bu durumu düzeltebilirseniz şayet uzun vadede zaman kaybından kurtulacağız.

Kod da başka sorun yok şuan için.

Saygılarımla.
 
Bora K' Alıntı:
Merhabalar
Süleyman Bey alakanız için birkez daha teşekkür ederim.
Toplam alır iken 40. satıra sayılacak veri isimlerini elle girmeden kod çalışmıyor.
Bu durumu düzeltebilirseniz şayet uzun vadede zaman kaybından kurtulacağız.
Kod da başka sorun yok şuan için.
Saygılarımla.
Genişletmek için tıkla ...

Her iki durum içinde çözüm sunuyorum ilk sorguda P7,Q7,R7... hücrelerindeki veriye göre sorgulama yaptırmaktayım. İkinci sorguda "Kullanıcı Sorgulu" doğrudan sizin yazacağınız kodu arayarak toplamları vermektedir. Yanlış hatırlamıyorsam her satırın sonuna sanki miktarlarınıda yazdırmam gerekiyor diye kodu o şekilde yazmıştım. Şimdi dosyayı tekrar incelermisiniz ?
 

Ekli dosyalar

Son düzenleme:
tasmed' Alıntı:
Merhaba, aşağıdaki kodu denermisiniz.
Kod: 
Sub Bora()
    sonsut = Cells(40, Columns.Count).End(xlToLeft).Column
    For s = 16 To sonsut + 1 Step 2
        For r = 8 To 40
            Cells(r, s) = 0
        Next r
    Next s

    For i = 8 To 38
        For j = 4 To 13
            For c = 15 To sonsut Step 2
                If Cells(i, j) = Cells(40, c) Then
                    Cells(i, c + 1) = Cells(i, c + 1) + WorksheetFunction.CountA(Cells(i, j))
                    Cells(40, c + 1) = Cells(40, c + 1) + WorksheetFunction.CountA(Cells(i, j))
                End If
            Next c
        Next j
    Next i
End Sub
Genişletmek için tıkla ...


Merhabalar
Sayın tasmed;

Örnek dosyamızdaki Kahverengi olan verilerin tamamını makronun üretmesi lazım.
Kahverengi yazıların tamamını sildiğimde kod çalışmıyor.
Toplamını alacağımız verileri yani (Elma Armut ve Erik) yerlerine yazdığım zaman
kod çalışıyor. Bu durumu düzeltme imkanınız varsa şayet çok sevinirim.

Teşekkürler.

Süleyman Bey.
Uğraşınız için ne kadar teşekkür etsem azdır.
Sayın tasmed üstadın kodu üzerinde yoğunlaşmak istiyorum.
mazur görünüz lütfen.

Saygılarımla.
 
Bora K' Alıntı:
Merhabalar
Süleyman Bey.
mazur görünüz lütfen.
Saygılarımla.
Genişletmek için tıkla ...

Tabi uygun olan kodu kullanın, Bende verileri filtreleyip yani tabloda ne kadar veri varsa o kadar veriyi kendifiltreleyip ona göre toplamları veren kodu düzenledim, Önceki mesajımdaki dosyayı güncelledim, Kolay gelsin.
 
Merhaba,

Alternatif olarak aşağıdaki kodu deneyiniz.

Kod: 
Sub OZET_RAPOR()
    Dim Veri As Range, Sutun As Integer, Dizi As Collection, Kriter As Variant, X As Integer
    
    Range("O8:" & Cells(40, Columns.Count).Address(0, 0)).ClearContents
    
    On Error Resume Next
    
    Set Dizi = New Collection
    
    For Each Veri In Range("D8:M38")
        If Veri.Value <> "" Then
            Dizi.Add Veri.Value, Veri.Text
        End If
    Next
    
    On Error GoTo 0
    
    Sutun = 16
    
    For Each Kriter In Dizi
        For X = 8 To 38
            Cells(X, Sutun) = WorksheetFunction.CountIf(Range("D" & X & ":M" & X), Kriter)
        Next
        
        Cells(40, Sutun - 1) = Kriter
        Cells(40, Sutun) = WorksheetFunction.Sum(Range(Cells(8, Sutun), Cells(38, Sutun)))
        Sutun = Sutun + 2
    Next
    
    Set Dizi = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Ayhan Hocam
kod harika olmuş iyiki varsınız.

Sagılarımla.
 
Merhaba,

Seçenek olsun.

Önce alan seçip sonra programı çalıştırınız.

Kod: 
Sub VeriVeAdedi()
    
    Dim Hücre   As Range, _
        d, _
        dKey, _
        dItem, _
        Deger
    
        If Not Selection.Count > 1 Then
            MsgBox "Alan Seçmediniz"
            Exit Sub
        End If
        
        Set d = CreateObject("Scripting.Dictionary")
        
        For Each Hücre In Selection
            If Not Hücre = "" Then
                Deger = Hücre
                If Not d.exists(Deger) Then
                    d.Add Deger, 1
                Else
                    d.Item(Deger) = d.Item(Deger) + 1
                End If
            End If
        Next Hücre
                
        dKey = d.keys
        dItem = d.items
        
        Range("Q8").Resize(UBound(d.keys) + 1, 1) = Application.WorksheetFunction.Transpose(dKey)
        Range("R8").Resize(UBound(d.keys) + 1, 1) = Application.WorksheetFunction.Transpose(dItem)
        
    
End Sub
 
Başlığın ismine uygun farklı ve pratik bir kod olmuş.

Necdet hocam ellerinize zihninize sağlık.
Herşey gönlünüzce olsun inşallah
saygılarımla.
 
Kodu yeniden düzenlemiştim, forma eklemiyi unutmuşum, zaten cevaplar gelmiş. Kodun düzenlenmiş hali;
Kod: 
Sub Bora()
sonsut = Cells(40, Columns.Count).End(xlToLeft).Column
sut = 15
For m = 8 To 38
For n = 4 To 13
If WorksheetFunction.CountIf(Range("D" & m & ":M3" & m), Cells(m, n)) = 1 Then
Cells(40, sut) = Cells(m, n)
sut = sut + 2
End If
Next n
Next m
sonsut = Cells(40, Columns.Count).End(xlToLeft).Column

    For s = 16 To sonsut + 1 Step 2
        For r = 8 To 40
            Cells(r, s).ClearContents
            Cells(r, s) = 0
        Next r
    Next s

    For i = 8 To 38
        For j = 4 To 13
            For c = 15 To sonsut Step 2
                If Cells(i, j) = Cells(40, c) Then
                    Cells(i, c + 1) = Cells(i, c + 1) + WorksheetFunction.CountA(Cells(i, j))
                    Cells(40, c + 1) = Cells(40, c + 1) + WorksheetFunction.CountA(Cells(i, j))
                End If
            Next c
        Next j
    Next i
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst