Porównanie dwóch kolumn podświetlenie pasujących wierszy

by dsp | wrz 10, 2012 | Porady, Software, Wiedza

Często e Excelu potrzebujemy zrobić porównanie dwóch kolumn i zamiast ręcznie szukać każdej pozycji można zastosować Makro.

Więc do Dzieła

Porównanie 2 kolumn w arkuszu i podświetlenie pasujących wartości.

Otwieramy arkusz excel-a, klikamy klawisz Makro

w zakładce Deweloper  .

Moza posłużyć się kombinacja klawiszy ALT + F11 lub jak ktoś niema zakładki Deweloper może sobie ja włączyć

Klikamy PLIK > OPCJE >Dostosowanie wstążki  i zaznaczamy „ptaszka” Przy DEWELOPER

Klikamy więc Makro i wpisujemy nazwę naszego  makra nr:porównanie ( ja wpisuje bez polskich znaków )

Otworzy się następne okienko gdzie wklejamy nasz kod ( ten poniżej )  poprawimy to co zaznaczone aby dopasować do swoich potrzeb zamykamy i

UWAGA

PAMIETAJ o zmianie parametrów pod swoje potrzeby .-

– Wybieramy nazwę arkusza

-Które  kolumny ma porównać ( kolumna A to 1 B to 2 itd..

-Możesz wybrać kolor zaznaczenia

A oto zbawienny kod makro który porówna nam dwie kolumny i zaznaczy powtarzające się fragmenty

Sub POROWNANIE()
Dim c1 As Integer, c2 As Integer
Dim i As Long, k As Long, count As Long
Dim lr1 As Long, lr2 As Long
Dim cf1 As String, cf2 As String
Dim WS As Worksheet
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

' Wpisz nazwę Arkusza

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

Set WS = Worksheets("Arkusz2") ' możena tez podać numer zakładki np: Set WS = Worksheets(2)

Application.ScreenUpdating = False
Application.StatusBar = "Chwila  przgotowuje raport raport..."
Application.DisplayAlerts = True

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

' Wpisz swoje  numer kolumny  które chcesz porównać  w C1 oraz   C2 oraz     (1 to kolumna  A  2 to  kolumna B  itd.)

'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
c1 = 1
c2 = 3

With WS.UsedRange
lr1 = .Rows.count
End With

For i = 2 To lr1
For k = 2 To lr1
cf1 = ""
cf2 = ""
On Error Resume Next
cf1 = WS.Cells(i, c1).FormulaLocal
cf2 = WS.Cells(k, c2).FormulaLocal
On Error GoTo 0
If cf1 = cf2 Then
count = count + 1

'Możesz zmienic kolor zamiast 46 wpisz wartość od 0-255
WS.Cells(i, c1).Interior.ColorIndex = 46
WS.Cells(i, c1).Select
Selection.Font.Bold = True

Exit For
End If
Next k
Next i
Application.StatusBar = "Przygotowuje raport......"
'Columns("A:IV").ColumnWidth = 10
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox count & " komórki zawierają te same wartości! ", vbInformation, _
"Porównano kolumnę  " & c1 & " z kolumną " & c2
End Sub

I to chyba wszystko

TH  team  🙂  Vertical Horizons