Bir değere karşılık gelen değerlerden büyüğünü dikkate almak

[y_yilmaz1977]

Merhabalar;

A sütunuda tekralayan sayılar var. B sütununda da bu sayılara karşılık gelen değerler.

Ben B sütunundaki bu değerlerden sadece büyük olanları dikkate alınsın istiyorum.

Örneğin;

A da yer alan 100 rakamının karşısında bir satırda 10 diğerinde 20 varsa 10 silinsin yerine 20 yazsın.

Dosyam ekte.

Saygılar.

 

[Korhan Ayhan]

Selamlar,

1. sorunuz için aşağıdaki kodu kullanabilirsiniz.

Option Explicit
 
Sub BUL_DEĞİŞTİR()
    Dim Veri As New Collection, X As Long, Eleman As Variant, Büyük_Değer As Long
    Dim Bul As Range, Adres As String
 
    On Error Resume Next
 
    For X = 1 To Range("A65536").End(3).Row
        Veri.Add Cells(X, 1), CStr(Cells(X, 1))
    Next
    On Error GoTo 0
 
    For Each Eleman In Veri
        Büyük_Değer = Evaluate("=LARGE(IF(A1:A65536=" & Eleman & ",B1:B65536),1)")
        If Büyük_Değer > 0 Then
            Set Bul = Range("A:A").Find(Eleman, LookAt:=xlWhole)
            If Not Bul Is Nothing Then
            Adres = Bul.Address
            Do
            Cells(Bul.Row, 2) = Büyük_Değer
            Set Bul = Range("A:A").FindNext(Bul)
            Loop While Not Bul Is Nothing And Bul.Address <> Adres
            End If
        End If
    Next
    Set Bul = Nothing
    Set Veri = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

2. sorunuz içinde aşağıdaki kodu kullanabilirsiniz.

Option Explicit
 
Sub VERİLERİ_SAY()
    Dim X As Long
 
    For X = 1 To Range("A65536").End(3).Row
        If Cells(X, 1) <> "" Then
            Cells(X, 2) = WorksheetFunction.CountIf(Range("A:A"), Cells(X, 1))
        End If
    Next
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[y_yilmaz1977]

Selamlar,

1. sorunuz için aşağıdaki kodu kullanabilirsiniz.

Option Explicit
 
Sub BUL_DEĞİŞTİR()
    Dim Veri As New Collection, X As Long, Eleman As Variant, Büyük_Değer As Long
    Dim Bul As Range, Adres As String
 
    On Error Resume Next
 
    For X = 1 To Range("A65536").End(3).Row
        Veri.Add Cells(X, 1), CStr(Cells(X, 1))
    Next
    On Error GoTo 0
 
    For Each Eleman In Veri
        Büyük_Değer = Evaluate("=LARGE(IF(A1:A65536=" & Eleman & ",B1:B65536),1)")
        If Büyük_Değer > 0 Then
            Set Bul = Range("A:A").Find(Eleman, LookAt:=xlWhole)
            If Not Bul Is Nothing Then
            Adres = Bul.Address
            Do
            Cells(Bul.Row, 2) = Büyük_Değer
            Set Bul = Range("A:A").FindNext(Bul)
            Loop While Not Bul Is Nothing And Bul.Address <> Adres
            End If
        End If
    Next
    Set Bul = Nothing
    Set Veri = Nothing
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

2. sorunuz içinde aşağıdaki kodu kullanabilirsiniz.

Option Explicit
 
Sub VERİLERİ_SAY()
    Dim X As Long
 
    For X = 1 To Range("A65536").End(3).Row
        If Cells(X, 1) <> "" Then
            Cells(X, 2) = WorksheetFunction.CountIf(Range("A:A"), Cells(X, 1))
        End If
    Next
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Korhan bey emeğiniz için çok teşekkür ederim. 2. soruma verdiğiniz cevap da herhangi bir sorun yok. Ancak 1. sorumda ekte gönderdiğim "run time error 13"
hatası veriyor. Sanırım bir yazım hatası var.

 

[Korhan Ayhan]

Selamlar,

Dosyayı deneyerek eklemiştim. Yine denedim ve bir sorunla karşılaşmadım. Sizin uyguladığınız dosyada bir sorun olabilir. Dosyanızı ekleyin inceleyelim.

 

[y_yilmaz1977]

Selamlar,

Dosyayı deneyerek eklemiştim. Yine denedim ve bir sorunla karşılaşmadım. Sizin uyguladığınız dosyada bir sorun olabilir. Dosyanızı ekleyin inceleyelim.

Korhan bey, dosyam ekte.