Prikazi cijelu temu 13.01.2019 17:08
Avko Van mreze
Administrator
Registrovan od:28.05.2014
Lokacija:zagreb


Predmet:Re: Kako da obrisem redove sa markiranim celijama
evo stigo zxz jer nije mogao vise mene da doceka.
Meni je bilo ovo tesko.

ajmo jos ovako pa da vidimo

metodom staviti kod u modul1 stavi ovo:

PreuzmiIzvorni kôd (Text):
  1. Sub duplikati()
  2.     If obojiDuplikate = True Then
  3.         If obrisiDuplikate = False Then
  4.             MsgBox "GRESKA! u brisanju duplikata"
  5.             Stop
  6.         End If
  7.     Else
  8.         MsgBox "GRESKA! u bojanju duplikata"
  9.         Stop
  10.     End If
  11. End Sub
  12.  
  13. Function obojiDuplikate() As Boolean
  14.     obojiDuplikate = False
  15.    
  16.     Dim LLoop As Integer
  17.     Dim LTestLoop As Integer
  18.     Dim LClearRange As String
  19.     Dim Lrows As Integer
  20.     Dim Lcol As Integer
  21.     Dim LRange As String
  22.  
  23.     'A kolona, vrijednosti
  24.     Dim LChangedValue As String
  25.     Dim LTestValue As String
  26.  
  27.     'B kolona vrijednosti
  28.     Dim LChangedValueB As String
  29.     Dim LTestValueB As String
  30.  
  31.     'Lrows=zadnjiRed
  32.     With ActiveSheet
  33.         Lrows = .Cells(Rows.count, "A").End(xlUp).Row
  34.         Lcol = .Cells(1, Columns.count).End(xlToLeft).Column
  35.     End With
  36.  
  37.     LLoop = 2
  38.  
  39.     'obrisi boje ispune
  40.     LClearRange = "A2:B" & Lrows
  41.     Range(LClearRange).Interior.ColorIndex = xlNone
  42.  
  43.     'provjeri sve redove
  44.     While LLoop <= Lrows
  45.         LChangedValue = "A" & CStr(LLoop)
  46.         LChangedValueB = "B" & CStr(LLoop)
  47.         If Len(Range(LChangedValue).Value) > 0 Then
  48.  
  49.          'Nadi jedinstvenu vrijednost
  50.          LTestLoop = 2
  51.          While LTestLoop <= Lrows
  52.             If LLoop <> LTestLoop Then
  53.                LTestValue = "A" & CStr(LTestLoop)
  54.                LTestValueB = "B" & CStr(LTestLoop)
  55.                'vrijednost je duplikat u drugoj celiji
  56.                If (Range(LChangedValue).Value = Range(LTestValue).Value) And (Range(LChangedValueB).Value = Range(LTestValueB).Value) Then
  57.                   'postavi crvenu boju pozadine u A stupcu
  58.                   Range(LChangedValue).Interior.ColorIndex = 3
  59.                   Range(LTestValue).Interior.ColorIndex = 3
  60.  
  61.                   'postavi crvenu boju pozadine u B stupcu
  62.                   'ovo netreba
  63.                   Range(LChangedValueB).Interior.ColorIndex = 3
  64.                   Range(LTestValueB).Interior.ColorIndex = 3
  65.                End If
  66.             End If
  67.             LTestLoop = LTestLoop + 1
  68.             Wend
  69.         End If
  70.         LLoop = LLoop + 1
  71.     Wend
  72.     obojiDuplikate = True
  73. End Function
  74.  
  75. Function obrisiDuplikate() As Boolean
  76.     obrisiDuplikate = False
  77.    
  78.     Dim rCell As Range
  79.     Dim rRange As Range
  80.     Dim lCount As Long
  81.      
  82.     Set rRange = Range("A1", Range("A" & Rows.count).End(xlUp))
  83.     lCount = rRange.Rows.count
  84.      
  85.     For lCount = lCount To 1 Step -1
  86.         With rRange.Cells(lCount, 1)
  87.             If WorksheetFunction.CountIf(rRange, .Value) > 1 Then
  88.                 .EntireRow.Delete
  89.             End If
  90.         End With
  91.     Next lCount
  92.     obrisiDuplikate = True
  93. End Function

metodom dodijeli kod dugmetu (kao sto sam prije rekao i objasnio), dodijeli mu makronaredbu imena : duplikati.

sada kada kliknes na dugme kod poziva funkciju koja oboji sve duplikate, a zatim se pozove funkcija obrisi duplikate, stime da ostane obojen jedan duplikat.

evo i excel primjer sa vocem.

Napomena : trebao si nam odmah na pocetku reci da si trazio duplikate metodom uvjetnog oblikovanja. Mislim da vba nemoze dijelovati na uvjetno oblikovanje ili moze...

Prilozi:
avko_01.rar
Preuzimanja:171
Velicina datoteke:18.08 KB

zivot je moja domovina.
Ovaj post je ureden 1 puta. Posljednja izmjena 13.01.2019 17:09 od strane Avko.