Eğersay hemen say!

[peleryn]

A1:L31 aralığındaki hücrelerden birine örneğin "ali" değerini girsem ve anında bu aralıkta "ali" adında girilen tek kayıt olduğu için hücreme girdiğim değer "ali 1" olarak değişse ikinci bir hücreye ve daha fazlasına "ali" değerini girdiğim zaman tüm hücrelerdeki aynı değerler "ali 1","ali 2","ali 3"...şeklinde görünse..ben de verimi girdiğim zaman o veriyi kaç kez girdiğimi görebilsem ve işim bittiğinde bir buton yardımıyla değerlerin yalın hallerine dönebilsem çok zevkli olacaktı.Bu zevki bana hediye edecek birisi çıkarsa çok mutlu olacağım.Herkese sevgiler.

 

[mami68]

Merhabalar...

A1=Ali
A2=Veli

B1=Eğersay($a$1:a1;a1) formülü yazdıktan sonra aşağı doğru sürükleyin.

C1=A1&B1 formülü yazdıktan sonra aşağı doğru sürükleyin

sanırım böyle bir şey istediğiniz.

İyi çalışmalar.

 

[peleryn]

ilginiz için teşekkür ederim mami68 istediğim sonuç evet c1 deki sonuç ama istediğim işlem şu:c1'e "ali" yazalım hücreden çıktığım anda belli bir aralıktaki "ali" leri saysın ve diyelim 5 tane buldu c1 hücresini ve diğer tüm "ali" yazan hücreleri "ali 5" olarak değiştirsin.mümkün müdür bilmiyorum ama bir umut soruyorum..

 

[mami68]

Dosyayı kontrol edermisiniz.

 

[mami68]

İkinci örnek

 

[peleryn]

İkinci örneğinizdeki gibi tüm değerler aynı olacak "ali5" gibi..ama bunu yaparken bir listeyi bir başka alanda değerlendirmeden hücreye yazılıp çıkıldığı anda yazılmış hücreyi değerlendirip değiştirecek (worksheet_activate içine yazılacak bir makro ile belkide)
bu arada verdiğiniz örnek dosya da çok işlevsel teşekkür ediyorum.

 

[peleryn]

şöyle daha iyi anlatabildim sanıyorum.dosyada mavi alana yazın ve pembe alana bakın.
ben pembe alan olmaksızın sadece mavi alanı böyle kullanabilir miyim diyorum.değerler değiştikçe kendisi de değişsin.en son da bir butonla yalın halini göreyim.

 

[Orion1]

Ekli dosyayı inceleyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim z As Object, deg As String, hcr As Range, i As Byte
If Intersect(Target, [I9:L21]) Is Nothing Then Exit Sub
If Target.Value = "" Then Exit Sub
Set z = CreateObject("Scripting.Dictionary")
Application.EnableEvents = False
For Each hcr In Range("I9:L21")
If hcr.Value <> "" Then
    deg = hcr.Value
    For i = 1 To 9
        deg = Replace(deg, i, "")
    Next i
    If Not z.exists(deg) Then
        z.Add (deg), 1
        Else
        z.Item(deg) = z.Item(deg) + 1
    End If
End If
Next hcr
For Each hcr In Range("I9:L21")
    If hcr.Value <> "" Then
    deg = hcr.Value
    For i = 1 To 9
        deg = Replace(deg, i, "")
    Next i
    hcr.Value = deg & z.Item(deg)
    End If
Next
Application.EnableEvents = True
End Sub

 

[peleryn]

Evren Bey harika olmuş tam istediğim gibi işliyor.Sadece sağ klik-içeriği temizle yaptığımda aşağıdaki satırda debugger çalışıyor

If Target.Value = "" Then Exit Sub

bir de istediğimde değerleri yalın halinde yani metin+sayısı değilde sadece metinler olarak görmemi sağlayacak bir buton eklenebilir mi?Bunu da yaptığımızda tam anlamıyla ihtiyaç duyduğum işi yapacak.

Emeğiniz için çok teşekkürler..

 

[Korhan Ayhan]

Selamlar,

Örnek dosyada Evren beyin size önermiş olduğu kodda bazı değişiklikler yaptım. Dosyadaki kodun tamamını silip aşağıdaki kodları uygulayıp denermisiniz.

Sayfada mavi renkli alanda herhangi bir hücreye çift tıklarsanız verilerin orjinal halini görebilirsiniz.

Dim Kontrol As Boolean
 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim deg As String, hcr As Range, i As Byte
    If Intersect(Target, [I9:L21]) Is Nothing Then Exit Sub
    Cancel = True
    For Each hcr In Range("I9:L21")
    If hcr.Value <> "" Then
        deg = hcr.Value
        For i = 0 To 9
            deg = Replace(deg, i, "")
        Next i
        Kontrol = True
        hcr.Value = deg
    End If
    Next
    Kontrol = False
End Sub
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim z As Object, deg As String, hcr As Range, i As Byte
    If Intersect(Target, [I9:L21]) Is Nothing Then Exit Sub
    If Target.Cells.Count > 1 Then Exit Sub
    If Target.Value = "" Then Exit Sub
    If Kontrol = False Then
    Set z = CreateObject("Scripting.Dictionary")
    Application.EnableEvents = False
    For Each hcr In Range("I9:L21")
    If hcr.Value <> "" Then
        deg = hcr.Value
        For i = 0 To 9
            deg = Replace(deg, i, "")
        Next i
        If Not z.exists(deg) Then
            z.Add (deg), 1
            Else
            z.Item(deg) = z.Item(deg) + 1
        End If
    End If
    Next hcr
    For Each hcr In Range("I9:L21")
        If hcr.Value <> "" Then
        deg = hcr.Value
        For i = 0 To 9
            deg = Replace(deg, i, "")
        Next i
        hcr.Value = deg & z.Item(deg)
        End If
    Next
    Application.EnableEvents = True
    End If
    Kontrol = False
End Sub

 

[peleryn]

Korhan Bey ellerinize sağlık çok güzel olmuş.bir tek sorunum kaldı misal 10 tane dede yazıp çift tıklayın göreceksiniz.9 dan fazla değeri sayıyor ama 10 dan sonra başına sıfır atıyor dede011 gibi ..çift tıklayınca da dede0 olarak değerleri temizliyor.bunun dışında tam istediğim kodlar oldu çok teşekkür ederim.

 

[Korhan Ayhan]

Selamlar,

Üstteki mesajımdaki kodu düzenlendim. İncelermisiniz.

 

[peleryn]

Korhan bey kodlar tam ihtiyacım olan şekilde çalışıyor ellerinize sağlık.Size ve Evren Bey'e ilgi ve emeğiniz için çok teşekkür ediyorum.