aynı isimde Gönderildi olanları bul

[gorby]

arkadaslar selam

mükerrer olan satırlardakı rakam yada yazıları "Conditional format" kısımda Dublıcat Values yardımıyla buluyorum. fakat istediğim belirli sartlara göre Makro kodlarına ihtiyacım bulunmaktadır.

1. sart ="H" kolonunda isimler aynı ise kaç satır olursa olsun altına bir bosluk bırakacak.

2.sart = "H" Kolondaki isimler ve "D" Kolontadaki tarihler aynısi ise,
Senaryo burda baslıyor, "C" Kolondaki "Yoksay ve Gönderildi" yazanların içinde 1'den fazla "Gönderildi" var ise, ilgili satırları boyanacak.

 

[parametre]

ornek dosya koyunuz

Slmlar konunuzu herkesin anlayacağı sekilde ornek dosya ile desteklerseniz size yardımcı oluruz kolay gelsin

 

[gorby]

dosya ekleyemiyoru örnek asağıdaki gbidir

Yoksay 23/04/2016 Aktog, Abdulmuttalip -5.00
Gönderildi 23/04/2016 Aktog, Abdulmuttalip 5.00 (boya)
Gönderildi 23/04/2016 Aktog, Abdulmuttalip 5.00 (boya)

Gönderildi 01/01/2016 Akturk, Burcak Keskinalemdag 7.00 (boyama)
Yoksay 31/12/2015 Akturk, Burcak Keskinalemdag 7.00 (boyama)
Yoksay 31/12/2015 Akturk, Burcak Keskinalemdag -7.00 (boyama)

 

[parametre]

dosya yukleme sitelerinden birine yukleyin link verin

 

[gorby]

http://dosya.co/a3mgl4kr5gzq/örnek.xlsx.html

 

[gorby]

Örnek anlaşılabılıniyormu belirli sarma baglı kalarak ilgili satırlar boyanacak

 

[gorby]

Yada countıf formulu kullanarak makro koda çevrilip aynı olanların saydırıp 1 den fazla gonderildı degerlerı boyanacak

 

[parametre]

inceleyiniz

2,

3
4

 

[Ziynettin]

....
Eki deneyiniz.

Sub Aktar_Renk()
Dim Krt As String
Z = TimeValue(Now)
son = Sheets("orjinal dosya").Cells(Rows.Count, 1).End(3).Row
a = Sheets("orjinal dosya").Range("A2:M" & son)
On Error Resume Next
Set d = CreateObject("scripting.Dictionary")
For i = 1 To UBound(a)
    If a(i, 8) <> a(i + 1, 8) Then
        say = say + 1
    End If
        Krt = Format(a(i, 4), "dd.mm.yyyy") & a(i, 8) & a(i, 10)
        d(Krt) = d(Krt) + 1
Next i
ReDim b(1 To UBound(a) + say, 1 To UBound(a, 2))
say = 0
For i = 1 To UBound(a)
    say = say + 1
    For k = 1 To UBound(a, 2)
        b(say, k) = a(i, k)
    Next k
    If a(i, 8) <> a(i + 1, 8) Then
        say = say + 1
    End If
Next i

If say > 1 Then
    With Sheets("Sayfa1")
        .Range("A2:M" & Rows.Count).Clear
        .[A2].Resize(say, UBound(a, 2)) = b
        .[D2].Resize(say).NumberFormat = "dd.mm.yyyy"
        c = .Range("A2:M" & say)
    For i = 1 To UBound(c)
        Krt = Format(c(i, 4), "dd.mm.yyyy") & c(i, 8) & c(i, 10)
        If Krt <> "" Then
            If d(Krt) > 1 Then
                .Range("A" & i + 1).Resize(, UBound(c, 2)).Interior.ColorIndex = 6
            End If
        End If
    Next i
    .Select
    End With
End If
MsgBox CDate(TimeValue(Now) - Z)
End Sub

http://s2.dosya.tc/server3/9z6o5m/AKTART_RENKLENDIR.rar.html

 

[gorby]

sayın Ziynettin aradığım tamda buydu, tesekkür ederim,
saygılar,

 

[Ziynettin]

Rica ederim,

İyi çalışmalar.