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

eceLprensi

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

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,500
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

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
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
97
Excel Vers. ve Dili
2016
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
97
Excel Vers. ve Dili
2016
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

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Sanırım şifrelemişsiniz.
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
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
97
Excel Vers. ve Dili
2016
Merhaba,



Şeklinde yapmak istiyorum.

yukardaki kodu kullanarak yaptım sonuç ise



bu şekilde
 

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,553
Excel Vers. ve Dili
Pro Plus 2021
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
97
Excel Vers. ve Dili
2016
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