Registracija

Brisanje duplikata, ne svih, pomocu makroa!

Odgovori Nova tema

1 odgovor
2.060 pregleda

Brisanje duplikata, ne svih, pomocu makroa! 20.01.2015. u 22:45 · pre 143 meseca #1

U prilogu je tabela. Da li moze da se napravi bilo kakav makro ili neka funkcija koji/a ce obrisati sve duplikate (kriterijum je kolona C) ali s time da se ostavi prva i poslednja celija. Oznacio sam crvenom bojom (ili zelena) sta mi je potrebno tj. sta bih zeleo da ostane nakon brisanja duplikata! U koloni F je samo razlika E-D i to mu dodje kao da je u u F9 MIN, a u F27 MAX pa i ovo moze da posluzi kao kriterijum ako je neophodno!

Za sva pitanja stojim na usluzi :D!

Unapred hvala!

Potpis

Cogito, Ergo, Sum

Proba-1.xls32k

Re: Brisanje duplikata, ne svih, pomocu makroa! 21.01.2015. u 07:28 · pre 143 meseca #2

Ako nekoga zanima resenje:

Sub DeleteDuplicates()
Dim ar
Dim i As Long, j As Long, n As Long
Dim Temp As String

ar = Sheets("Sheet1").Range("B4").CurrentRegion.Value
Temp = ar(2, 2)
n = 3 'We keep the first 2 rows (header and first value)
For i = 3 To UBound(ar, 1) - 1
'First Value
If ar(i, 2) = Temp And ar(i + 1, 2) <> Temp Then
For j = 1 To UBound(ar, 2)
ar(n, j) = ar(i, j)
Next j
n = n + 1
End If

'Last Value
If ar(i - 1, 2) = Temp And ar(i, 2) <> Temp Then
Temp = ar(i, 2)
For j = 1 To UBound(ar, 2)
ar(n, j) = ar(i, j)
Next j
n = n + 1
End If
Next i

'We keep the last value
For j = 1 To UBound(ar, 2)
ar(n, j) = ar(UBound(ar, 1), j)
Next j

'Output results in other sheet
Sheets("Sheet2").Range("A1").Resize(n, UBound(ar, 2)) = ar

End Sub

Potpis

Cogito, Ergo, Sum

Prijavite se da biste odgovorili u ovoj temi.Prijava Registracija

Forum kao aplikacija na telefonu

Srodne teme