Banyak cara dapat dilakukan untuk mencari data yang sama didalam excel, terkadang kita butuh mencari data yang sama dan menandainya untuk suatu kebutuhan. dalam kode berikut kita dapat belajar dari Marcin Egert dalam blognya (www.excelblog.ca).
Pertama buatlah dua sheet data, satu untuk pemberian warna yang satunya lagi untuk cek duplikat data. Buatlah susunan range:
1. Untuk jumlah antrian warna definisikan dengan (rngjmlwrn)
2. Warna dasar jika tidak ada definisikan dengan (rngdasarwrn)
3. Warna awal perubahan definisikan dengan (rngawalwrn) susunlah warna dibawah susunan range ini, tiap baris dibuat berbeda warnanya.
4. Pada sheet yang berikutnya definisikan penempatan data dengan (rngcekdata),
Alt + F11 untuk membuka Visual Basic Editor (VBE). Kemudian isikan kode berikut ini pada sheet yang kedua. Atau tempat penempatan data.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngwarna As Range
Dim rngtempatsel As Range
Dim Bariswarna As Integer
Dim Berwarna As Integer
Dim rngkolomwrn As Range
Dim rngdupwarna As Range
' sel dengan warna yang telah dipilih
Set rngwarna = wksKolory.Range("rngawalwrn").Resize(wksKolory.Range("rngjmlwrn").Value, 1)
' sel dengan data yang telah diwarnai
Set rngtempatsel = wksDane.Range(Range("rngcekdata"), Cells(65535, Range("rngcekdata").Column).End(xlUp))
' kolom dengan data
Set rngkolomwrn = Columns("B")
With wksDane
Set rngdupwarna = .Range(.Range("rngcekdata"), .Range("rngcekdata").Offset(10000).End(xlUp))
End With
If Not Intersect(Target, rngkolomwrn) Is Nothing Then
Application.ScreenUpdating = False '
' kemudian bersihkan area data (kembalikan warna seperti semula)
rngdupwarna.Resize(rngdupwarna.Count + 1).Interior.ColorIndex = _
wksKolory.Range("rngdasarwrn").Interior.ColorIndex
Bariswarna = 1 ' reset warna
With rngtempatsel
' sel pertama
If Application.WorksheetFunction.CountIf(rngtempatsel, .Cells(1).Value) > 1 Then
.Cells(1).Interior.ColorIndex = rngwarna.Cells(Bariswarna).Interior.ColorIndex
Bariswarna = Bariswarna + 1
If Bariswarna > rngwarna.Count Then Bariswarna = 1
End If
'lebih dari satu sel
If rngdupwarna.Count > 1 Then
' pada sel yang mengikuti
For Berwarna = 2 To .Count
If Application.WorksheetFunction.CountIf(rngtempatsel, _
.Cells(Berwarna).Value) > 1 Then
If Application.WorksheetFunction.CountIf(Range("rngcekdata").Resize(Berwarna - 1), .Cells(Berwarna).Value) > 0 Then
.Cells(Berwarna).Interior.ColorIndex = _
rngdupwarna.Find(what:=.Cells(Berwarna).Value, after:=.Cells(Berwarna), SearchDirection:=xlPrevious, lookat:=xlWhole).Interior.ColorIndex
Else
.Cells(Berwarna).Interior.ColorIndex = rngwarna.Cells(Bariswarna).Interior.ColorIndex
Bariswarna = Bariswarna + 1
If Bariswarna > rngwarna.Count Then Bariswarna = 1
End If
End If
Next Berwarna
End If
End With
Application.ScreenUpdating = True
End If
End Sub
Tutup VBE (Alt + Q atau X di pojok kanan atas) coba perubahan.
Ataupun kita butuh mengeliminasi data yang sama kemudian menghapus salah satu baris jika ada kode yang sama didalamnya. berikut kita dapat belajar dari (www.vbaexpress.com)
Sub DeleteDups()
Dim x As Long
Dim LastRow As Long
LastRow = Range("A65536").End(xlUp).Row
For x = LastRow To 1 Step -1
If Application.WorksheetFunction.CountIf(Range("A1:A" & x), Range("A" & x).Text) > 1 Then
Range("A" & x).EntireRow.Delete
End If
Next x
End Sub
Pengaplikasian:
1. Buka Excel.
2. Alt + F11 untuk membuka Visual Basic Editor (VBE).
3. Sisipkan-Modul.
4. Sisipkan kode.
5. Tutup VBE (Alt + Q atau X di pojok kanan atas)
