Makro ile yinelenen değerlere değer yazdırma

[eceLprensi]

[TR][TD]

Merhaba,
ben raporumda yinelenen değerler var ve bunların yanlarındaki sütunda değerler farklı,
Örneğin ahmet kişisinde "tamam" ve "devam" var. ben son sütuna karma yazmak istiyorum





istediğim tablo ise



Şimdiden okuyan ve yorum yapacak arkadaşlara teşekkür ediyorum.
[/TD]
[TD]

[/TD][/TR]
[TR][TD]

[/TD]
[TD]

[/TD]
[TD]

[/TD][/TR]

 

[Murat OSMA]

Merhaba,
Gönüllü olarak, işinden, özel zamanından vakit ayırıp size yardımcı olacak kişileri uğraştırmamak adına, örnek dosya eklemeyi alışkanlık hâline getirelim. Sonrasında herkes elinden geldiğince yardımcı olacaklardır.

Saygılar

 

[Korhan Ayhan]

Murat beyin uyarısına kesinlikle katılıyorum.

Ben kodu hazırlamıştım. Bir ara denersiniz.

Option Explicit

Sub Analiz()
    Dim Veri As Variant, Son As Long
    Dim X As Long, Y As Long, Zaman As Double
    
    Zaman = Timer
        
    Range("C2:C" & Rows.Count).ClearContents
        
    Son = Cells(Rows.Count, 1).End(3).Row
    If Son = 2 Then Son = 3
    Veri = Range("A2:C" & Son).Value
    
    For X = LBound(Veri) To UBound(Veri)
        If X = UBound(Veri) Then
            If Veri(X, 3) = "" Then Veri(X, 3) = Veri(X, 2)
        End If
        For Y = X + 1 To UBound(Veri)
            If Veri(X, 1) = Veri(Y, 1) Then
                If Veri(X, 2) <> Veri(Y, 2) Then
                    Veri(X, 3) = "Karma"
                    Veri(Y, 3) = "Karma"
                Else
                    Veri(X, 3) = Veri(X, 2)
                    Veri(Y, 3) = Veri(Y, 2)
                End If
            Else
                If Veri(X, 3) = "" Then Veri(X, 3) = Veri(X, 2)
                X = Y - 1
                Exit For
            End If
        Next
    Next
    
    Range("A2").Resize(UBound(Veri, 1), UBound(Veri, 2)) = Veri
    Columns.AutoFit
    
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[eceLprensi]

MErhaba,

Murat OSMA kardeşim kusuruma bakma hazırlayamadım haklısın.
Korhan Ayhan ellerine emeklerine sağlık gerçekten hayat kurtardın.

çok çok teşekkürler.

 

[Korhan Ayhan]

Excel nelere kadirmiş..

... gerçekten hayat kurtardın.

 

[eceLprensi]

Merhaba,
dosyayı buraya yükleyemedim ama bi site yardımıyla atabiliyorum
https://
dosya.co/i1scn63vrpbj/
Kitap1.xlsx.html


c stununa Farklı değer gelenlere
bekleyen diğeri açık teslimatsa Karma yazmak istiyorum.

Yukardaki makroda bazı değeri atlıyor.

 

[Korhan Ayhan]

Sanırım şifrelemişsiniz.

 

[eceLprensi]

site istemişti 2012

 

[Korhan Ayhan]

Olmayan yer için örnek verir misiniz?

Siz nasıl olmasını istiyordunuz? Sonuç nasıl oldu?

 

[eceLprensi]

Merhaba,



Şeklinde yapmak istiyorum.

yukardaki kodu kullanarak yaptım sonuç ise



bu şekilde

 

[veyselemre]

Sub test()
    Range("C2:C" & Rows.Count).ClearContents
    liste = Range("A2:C" & Cells(Rows.Count, 1).End(3).Row).Value
    With CreateObject("Scripting.Dictionary")
        For i = LBound(liste) To UBound(liste)
            al = liste(i, 1)
            If .exists(al) Then
                ver = .Item(al)
                If ver <> "Karma" And ver <> liste(i, 2) Then .Item(al) = "Karma"
            Else
                .Item(al) = liste(i, 2)
            End If
        Next i
        For i = LBound(liste) To UBound(liste)
            liste(i, 3) = .Item(liste(i, 1))
        Next i
    End With
    Range("a2").Resize(UBound(liste), 3) = liste
End Sub

 

[eceLprensi]

veyselemre test ve sonuç; bu kadar net ve güzel olabilir.
Korhan Ayhan bey sizede destekleriniz için ayrıca teşekkürler.
çok teşekürler emekleriinize sağlık.