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
Cogito, Ergo, Sum
Brisanje duplikata, ne svih, pomocu makroa!
Registrovani: 9 ( AcidMaster, Getsbi, caprrri, branko tod, valjan, iculibrk, bojanum, Turmen, mosfet BJT )
Re: Brisanje duplikata, ne svih, pomocu makroa!