Loncat ke daftar isi utama

Bagaimana cara menyorot nilai duplikat dalam berbagai warna di Excel?

Pengarang: Xiaoyang Terakhir Dimodifikasi: 2020-12-25
doc berbeda warna duplikat 1

Di Excel, kita dapat dengan mudah menyorot nilai duplikat dalam kolom dengan satu warna dengan menggunakan Format Bersyarat, tetapi, terkadang, kita perlu menyorot nilai duplikat dalam warna berbeda untuk mengenali duplikat dengan cepat dan mudah seperti gambar berikut yang ditampilkan. Bagaimana Anda bisa menyelesaikan tugas ini di Excel?

Sorot nilai duplikat dalam kolom dengan warna berbeda menggunakan kode VBA

panah gelembung kanan biru Sorot nilai duplikat dalam kolom dengan warna berbeda menggunakan kode VBA

Sebenarnya, tidak ada cara langsung bagi kami untuk menyelesaikan pekerjaan ini di Excel, tetapi, kode VBA di bawah ini dapat membantu Anda, lakukan hal berikut:

1. Pilih kolom nilai yang ingin Anda sorot duplikat dengan warna berbeda, lalu tahan ALT + F11 kunci untuk membuka Microsoft Visual Basic untuk Aplikasi jendela.

2. Klik Menyisipkan > Modul, dan tempel kode berikut di Modul Jendela.

Kode VBA: Sorot nilai duplikat dalam berbagai warna:

Sub ColorCompanyDuplicates()
'Updateby Extendoffice
    Dim xRg As Range
    Dim xTxt As String
    Dim xCell As Range
    Dim xChar As String
    Dim xCellPre As Range
    Dim xCIndex As Long
    Dim xCol As Collection
    Dim I As Long
    On Error Resume Next
    If ActiveWindow.RangeSelection.Count > 1 Then
      xTxt = ActiveWindow.RangeSelection.AddressLocal
    Else
      xTxt = ActiveSheet.UsedRange.AddressLocal
    End If
    Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    xCIndex = 2
    Set xCol = New Collection
    For Each xCell In xRg
      On Error Resume Next
      xCol.Add xCell, xCell.Text
      If Err.Number = 457 Then
        xCIndex = xCIndex + 1
        Set xCellPre = xCol(xCell.Text)
        If xCellPre.Interior.ColorIndex = xlNone Then xCellPre.Interior.ColorIndex = xCIndex
        xCell.Interior.ColorIndex = xCellPre.Interior.ColorIndex
      ElseIf Err.Number = 9 Then
        MsgBox "Too many duplicate companies!", vbCritical, "Kutools for Excel"
        Exit Sub
      End If
      On Error GoTo 0
    Next
End Sub

3. Lalu tekan F5 kunci untuk menjalankan kode ini, dan kotak prompt akan mengingatkan Anda untuk memilih rentang data yang ingin Anda sorot nilai duplikat, lihat tangkapan layar:

doc berbeda warna duplikat 2

4. Lalu klik OK tombol, semua nilai duplikat telah disorot dalam warna berbeda, lihat tangkapan layar:

doc berbeda warna duplikat 1

Alat Produktivitas Kantor Terbaik

🤖 Kutools AI Ajudan: Merevolusi analisis data berdasarkan: Eksekusi Cerdas   |  Hasilkan Kode  |  Buat Rumus Khusus  |  Analisis Data dan Hasilkan Grafik  |  Aktifkan Fungsi Kutools...
Fitur Populer: Temukan, Sorot, atau Identifikasi Duplikat   |  Hapus Baris Kosong   |  Gabungkan Kolom atau Sel tanpa Kehilangan Data   |   Putaran tanpa Formula ...
Pencarian Super: VLookup Beberapa Kriteria  |   VLookup Nilai Berganda  |   VLookup di Beberapa Lembar   |   Pencarian Fuzzy ....
Daftar Drop-down Lanjutan: Buat Daftar Drop Down dengan Cepat   |  Daftar Drop Down yang Bergantung   |  Multi-pilih Drop Down List ....
Manajer Kolom: Tambahkan Jumlah Kolom Tertentu  |  Pindahkan Kolom  |  Alihkan Status Visibilitas Kolom Tersembunyi  |  Bandingkan Rentang & Kolom ...
Fitur Unggulan: Fokus Kisi   |  Tampilan Desain   |   Bar Formula Besar   |  Manajer Buku Kerja & Lembar   |  Perpustakaan Sumberdaya (Teks otomatis)   |  Pemetik tanggal   |  Gabungkan Lembar Kerja   |  Enkripsi/Dekripsi Sel   |  Kirim Email berdasarkan Daftar   |  Filter Super   |   Filter Khusus (filter tebal/miring/coret...) ...
15 Perangkat Teratas:  12 Teks Tools (Tambahkan Teks, Hapus Karakter, ...)   |   50 + Grafik jenis (Gantt Chart, ...)   |   40+ Praktis Rumus (Hitung usia berdasarkan ulang tahun, ...)   |   19 Insersi Tools (Masukkan Kode QR, Sisipkan Gambar dari Jalur, ...)   |   12 Konversi Tools (Angka ke Kata, Konversi Mata Uang, ...)   |   7 Gabungkan & Pisahkan Tools (Lanjutan Gabungkan Baris, Pisahkan Sel, ...)   |   ... dan banyak lagi

Tingkatkan Keterampilan Excel Anda dengan Kutools for Excel, dan Rasakan Efisiensi yang Belum Pernah Ada Sebelumnya. Kutools for Excel Menawarkan Lebih dari 300 Fitur Lanjutan untuk Meningkatkan Produktivitas dan Menghemat Waktu.  Klik Di Sini untuk Mendapatkan Fitur yang Paling Anda Butuhkan...

Deskripsi Produk

Tab Office Membawa antarmuka Tab ke Office, dan Membuat Pekerjaan Anda Jauh Lebih Mudah

  • Aktifkan pengeditan dan pembacaan tab di Word, Excel, PowerPoint, Publisher, Access, Visio, dan Project.
  • Buka dan buat banyak dokumen di tab baru di jendela yang sama, bukan di jendela baru.
  • Meningkatkan produktivitas Anda sebesar 50%, dan mengurangi ratusan klik mouse untuk Anda setiap hari!
Comments (98)
Rated 5 out of 5 · 1 ratings
strulip.rva@gmail.com
This comment was minimized by the moderator on the site
Thanks for the code but this code has a limitation on the amount of highlighted pairs. For example if your table has more then several hundreds duplicate pairs it does not work. Besides in my case it also highlights the cells that are empty. So I have not found any working code so i made another code by myself and it works perfectly with any range. Test please guys:

Sub DuplicatesColoring()
Dim rng As Range
Dim objDictDupes As Object
Dim cell As Range
Dim I As Integer

' Prompt user to select the range
On Error Resume Next
Set rng = Application.InputBox("Please select the range:", Type:=8)
On Error GoTo 0

' Check if a range was selected
If rng Is Nothing Then
MsgBox "No range selected. Exiting the macro.", vbExclamation
Exit Sub
End If

Set objDictDupes = CreateObject("Scripting.Dictionary")
rng.Interior.ColorIndex = -4142
I = 3

For Each cell In rng
If cell.Value <> "" Then ' Check if cell is not empty
If objDictDupes.Exists(cell.Value) Then
If objDictDupes.Item(cell.Value).Interior.ColorIndex <> -4142 Then
cell.Interior.ColorIndex = objDictDupes.Item(cell.Value).Interior.ColorIndex
Else
objDictDupes.Item(cell.Value).Interior.ColorIndex = I
cell.Interior.ColorIndex = I
I = I + 1
End If
Else
objDictDupes.Add cell.Value, cell
End If
End If
Next cell
End Sub
Reply
Report
0
0
Volker Maier
Volker Maier
This comment was minimized by the moderator on the site
Hallo. Thats very helpfull. But it seems only working when you do not have much cells.
Is there a way to get it running with more then 100 cells an 15 rows

Thank you in advanced.

Kind regards
Volker
Reply
0
0
strulip.rva@gmail.com
    Volker Maier
This comment was minimized by the moderator on the site
I had the same problem and besides it was highlighting blank cells. I have made my own code and works perfectly:

Sub DuplicatesColoring()
Dim rng As Range
Dim objDictDupes As Object
Dim cell As Range
Dim I As Integer

' Prompt user to select the range
On Error Resume Next
Set rng = Application.InputBox("Please select the range:", Type:=8)
On Error GoTo 0

' Check if a range was selected
If rng Is Nothing Then
MsgBox "No range selected. Exiting the macro.", vbExclamation
Exit Sub
End If

Set objDictDupes = CreateObject("Scripting.Dictionary")
rng.Interior.ColorIndex = -4142
I = 3

For Each cell In rng
If cell.Value <> "" Then ' Check if cell is not empty
If objDictDupes.Exists(cell.Value) Then
If objDictDupes.Item(cell.Value).Interior.ColorIndex <> -4142 Then
cell.Interior.ColorIndex = objDictDupes.Item(cell.Value).Interior.ColorIndex
Else
objDictDupes.Item(cell.Value).Interior.ColorIndex = I
cell.Interior.ColorIndex = I
I = I + 1
End If
Else
objDictDupes.Add cell.Value, cell
End If
End If
Next cell
End Sub
Reply
Report
0
0
Manfred James Dandan
Manfred James Dandan
This comment was minimized by the moderator on the site
Very helpful! Thanks a lot for sharing :-)
Reply
0
0
mahmoud
mahmoud
This comment was minimized by the moderator on the site
it only applies to 5 duplicates then don't work
Reply
0
0
EsA
EsA
This comment was minimized by the moderator on the site
Works perfect.. Thanks alot...
Reply
Report
0
0
Rated 5 out of 5
EsA
EsA
This comment was minimized by the moderator on the site
Works perfect.. Thanks alot..
Reply
0
0
Rated 5 out of 5
Christina L
Christina L
This comment was minimized by the moderator on the site
Hi, thank you for this, I am having an issue though.

When I hit F5 it brings up the macros screen instead of a prompt to select the column data selection so all I could see was to hit "run" however I then get an error message to say;

Compile error:

Ecpected: end of statement.

Can you help please?
Reply
0
0
ALEJANDRO
ALEJANDRO
This comment was minimized by the moderator on the site
Funcionó perfecto. Muchas gracias.
Reply
0
0
pucci
pucci
This comment was minimized by the moderator on the site
perfect, i love u
Reply
0
0
hayyi
hayyi
This comment was minimized by the moderator on the site
this code left some duplicates with no fill (often those with one pair) can u check the code why and give me new please? ps. document have 6000+ positions and sometimes 5 to 10 duplicates 
Reply
0
0
skyyang
skyyang     hayyi
This comment was minimized by the moderator on the site
Hello, hayyi,Yes, as you said, the code in this article does not work well when there are lots of duplicate cells, in this case, you can try the below code:<div data-tag="code">Sub Colorduplicates()
On Error Resume Next
c = InputBox("Please enter the column heading you want to highlight cells", , "A")
r = Cells(65536, c).End(xlUp).Row
arr = Cells(1, c).Resize(r, 1).Value
Set d = CreateObject("scripting.dictionary")
For I = 1 To r
d(arr(I, 1)) = d(arr(I, 1)) + 1
Next I
ks = d.keys
its = d.items
For I = 0 To UBound(ks)
If its(I) > 1 Then
d.Item(ks(I)) = RGB(Int(Rnd * 99) + 99, Int(Rnd * 99) + 99, Int(Rnd * 99) + 99)
Else
d.Item(ks(I)) = xlNone
End If
Next
t = Cells(1, 256).End(xlToLeft).Column
For I = 1 To r
Cells(I, 1).Resize(1, t).Interior.Color = d(arr(I, 1))
Next
Set d = Nothing
End SubIf this code can help you, please let me know. Thank you！
Reply
Report
0
0
There are no comments posted here yet
Load More
Please leave your comments in English
Guest
Posting as Guest
×
Rate this post:
Reset
0   Characters
Suggested Locations