Aynı tarihe sahip sayfalar

[k0081]

Merhaba arkadaşlar;

Bir formül yada makro oluşturmak istiyorum;


excel sayfası içinde; A B C D E F G şeklinde sayfalar mevcut.

sayfalar içinde;
B3 sütunu TARİH bilgisi içeriyor. B3..B78

Aynı tarihden kaç tane var ? bunu nasıl yapabilirim..?

yardımcı arkadaşa şimdiden teşekkürler..

 

[Necdet]

Merhaba,

Sadece B3 hücresi mi tarih içeriyor? Yoksa B3:B78 Aralığında mi tarihler var?

Yani tüm sayfaların B3:B89 aralığında aynı tarihten kaç adet Tarih olduğunu mu soruyorsunuz?

Sonuç nereye yazılacak, belirli bir sayfa adı var mı?

 

[Necdet]

Sorularıma yanıt gelmemiş ama ben anladığım kadarıyla kod yazdım.

Tüm sayfaların B3:B78 aralığındaki tarihleri sayar.
Sonuc Adlı bir sayfaya sonucu yazar. Bu Sayfanın olması gerekir.

Sub AyniTarihleriSay()

    Dim i As Integer, _
        d, _
        Deg As Variant, _
        Syf As Worksheet
    
    Set d = CreateObject("Scripting.Dictionary")
    
    For Each Syf In Sheets
    
        If Not Syf.Name = "Sonuc" Then
            For i = 3 To 78
                Deg = Syf.Cells(i, "B")
                If IsDate(Deg) Then
                    If Not d.exists(Deg) Then
                        d.Add Deg, 1
                    Else
                        d.Item(Deg) = d.Item(Deg) + 1
                    End If
                End If
            Next i
        End If
        
    Next Syf
    
    Sheets("Sonuc").Select
    Range("A:B").ClearContents
    
    MsgBox d.Count & " Adet Değişik Tarih Bulundu ...."
   
    Range("A1").Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))

    Set d = Nothing
    
End Sub

 

[k0081]

Necdet Yeşertener

Hocam yoğunluk vardı.. şimdi yeni bakıyorum.. sonucu burdan güncelleyeceğim..


************************* *************************************

Hocam şu hatayı alıyorum;

http://s8.dosya.tc/server5/r1u67b/Hata.rar.html
***************************************************************

 

[k0081]

Merhaba,

Sadece B3 hücresi mi tarih içeriyor? Yoksa B3:B78 Aralığında mi tarihler var?

Yani tüm sayfaların B3:B89 aralığında aynı tarihten kaç adet Tarih olduğunu mu soruyorsunuz?

Sonuç nereye yazılacak, belirli bir sayfa adı var mı?

* B3:B78 Aralığında tarihler var.
* B3:B78 aralığında aynı tarihten kaç tane var., onları bulmak istiyorum evet.

Not: bulanacak bu sayı 7 adet sheet bakılıpta sonuç alınacak..

 

[Necdet]

Merhaba,

Kodları yeniledim. Ama dosyanızda Sonuc Adlı bir sayfa olması gerekiyor, o sayfada listeletiyorum.

 

[k0081]

Merhaba,

Kodları yeniledim. Ama dosyanızda Sonuc Adlı bir sayfa olması gerekiyor, o sayfada listeletiyorum.

Nejdet Hocam tamamdır, Elinize sağlık..

Eğer çok sıkıntı değilse şöyle bişey ekleyebilirmiyiz?

1- Aynı Tarihleri alırken VİNÇ ibaresi olanları saysın. VİNÇ bilgisi C3..C78 arasındadır.

2- bir de sayfa adlarınıda kenara yazabilirse , mükemmel olur hocam..

Çok teşekkür ediyorum, Saygılar sunuyorum.


******************** BU SORUN ÇÖZÜLMÜŞTÜR. ****************************

 

[Necdet]

Merhaba,

Kod ve isteğin son hali.

Sub AyniTarihleriSay()

    Dim i As Integer, _
        d, _
        Deg As Variant, _
        Syf As Worksheet, _
        Sut
        
    Application.ScreenUpdating = False
    
    Set d = CreateObject("Scripting.Dictionary")
    
    For Each Syf In Sheets
    
        If Not Syf.Name = "Sonuc" Then
            For i = 3 To 78
                Deg = Syf.Cells(i, "B")
                If IsDate(Deg) And UCase(Replace(Replace(Syf.Cells(i, "C"), "i", "İ"), "ı", "I")) = "VİNÇ" Then
                    If Not d.exists(Deg) Then
                        d.Add Deg, Syf.Name & "|" & 1
                    Else
                        Sut = Split(d.Item(Deg), "|")
                        Sut(0) = Sut(0) & " " & Syf.Name
                        Sut(1) = Sut(1) + 1
                        d.Item(Deg) = Sut(0) & "|" & Sut(1)
                    End If
                End If
            Next i
        End If
        
    Next Syf
    
    Sheets("Sonuc").Select
    Range("A:C").ClearContents
    
    MsgBox d.Count & " Adet Değişik Tarih Bulundu ...."
   
    Range("A1").Resize(d.Count, 2) = Application.Transpose(Array(d.keys, d.items))

    Set d = Nothing
    
    Columns("B:B").TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, OtherChar _
        :="|", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Range("C1").Select
    
    Application.ScreenUpdating = True
    
End Sub

 

[k0081]

Necdet Yeşertener

Hocam çok teşekkür ederim, Tamamdır. Elinize sağlık. çok güzel oldu.

Saygılar.

 

[Necdet]

Güle güle kullanın.