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

eceLprensi

Altın Üye
Katılım
30 Ekim 2007
Mesajlar
42
Excel Vers. ve Dili
2003

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.

 
   
 
Son düzenleme:

Murat OSMA

Altın Üye
Altın Üye
Katılım
23 Mayıs 2011
Mesajlar
5,402
Excel Vers. ve Dili
Microsoft 365 TR-EN
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

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
27,566
Excel Vers. ve Dili
OFFICE 2019 PRO TR
Murat beyin uyarısına kesinlikle katılıyorum.

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

C++:
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

Altın Üye
Katılım
30 Ekim 2007
Mesajlar
42
Excel Vers. ve Dili
2003
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.
 

eceLprensi

Altın Üye
Katılım
30 Ekim 2007
Mesajlar
42
Excel Vers. ve Dili
2003
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

Moderatör
Yönetici
Katılım
15 Mart 2005
Mesajlar
27,566
Excel Vers. ve Dili
OFFICE 2019 PRO TR
Olmayan yer için örnek verir misiniz?

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

eceLprensi

Altın Üye
Katılım
30 Ekim 2007
Mesajlar
42
Excel Vers. ve Dili
2003
Merhaba,



Şeklinde yapmak istiyorum.

yukardaki kodu kullanarak yaptım sonuç ise



bu şekilde
 

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
2,601
Excel Vers. ve Dili
Excel 2003-tr
Kod:
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

Altın Üye
Katılım
30 Ekim 2007
Mesajlar
42
Excel Vers. ve Dili
2003
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.
 
Üst