Lompat ke konten Lompat ke sidebar Lompat ke footer

Mencari data yang sama dalam excel

Apajadinya bila dalam penginputan data terdapat perulangan. data akan termuat dua kali atau lebih, ini bisa berakibat fatal dalam jumlah dan keakuratan data. ini pun sama halnya apabila kita mempunyai banyak baris data, namun hanya menghendaki data yang unik saja di dalamnya. kode vba berikut ini dapat digunakan untuk menghapus atau menandai data yang sama.
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)