+48 691 928 403 biuro@kielceserwis.pl
Porównanie dwóch arkuszy Excel-a Makro Excel

Porównanie dwóch arkuszy Excel-a Makro Excel

utworzone przez | wrz 11, 2012 | Porady, Software, Wiedza, Z życia

Porównanie dwóch arkuszy programu Excel korzystając Makro Excela , zaznacz  z duplikowane wiersze skopiować je do nowego arkusza excel.

Mamy dwa arkusze w Excelu i chcemy je porównać ze sobą . A pasujące wiersze przekopiować do nowego arkusza Excela

Może komuś będzie to przydatne

Rozwiń jeżeli nie wiesz jak zacząć i z czym się to je

Aby dowiedzieć się więcej, kliknij tutaj

Jeżeli ktoś nie wie jak zacząć  to Niech zajrzy do tego Wpisu

 

Pamiętaj o zmianie parametrów pod swój arkusz czyli

-Nazwy arkuszy w CompareWorksheets Worksheets(„Arkusz1”), Worksheets(„Arkusz2”)  Lub zimnń samemu

Sub Compare()
'
' Macro1 Macro
'CompareWorksheets Worksheets("WPISZ SWOJĄ NAZWE ARKUSZA"), Worksheets("WPISZ SWOJA NAZWĘ ARKUSZA DRUGIEGO ")
'
' compare two different worksheets in the active workbook

CompareWorksheets Worksheets("Arkusz1"), Worksheets("Arkusz2")
End Sub

Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet)
Dim dupRow As Boolean
Dim r As Long, c As Integer, m As Integer
Dim lr1 As Long, lr2 As Long, lc1 As Integer, lc2 As Integer, lr3 As Long
Dim maxR As Long, maxC As Integer, cf1 As String, cf2 As String
Dim dupCount As Long

Application.ScreenUpdating = False
Application.StatusBar = "Creating the report..."
Application.DisplayAlerts = True

With ws1.UsedRange
lr1 = .Rows.Count
lc1 = .Columns.Count
End With

With ws2.UsedRange
lr2 = .Rows.Count
lc2 = .Columns.Count
End With
maxR = lr1
maxC = lc1
If maxR < lr2 Then maxR = lr2
If maxC < lc2 Then maxC = lc2
DiffCount = 0
lr3 = 1
For i = 1 To lr1
dupRow = True

Application.StatusBar = "Comparing cells " & Format(i / maxR, "0 %") & "..."

For r = 1 To lr2
For c = 1 To maxC

ws1.Select
cf1 = ""
cf2 = ""

On Error Resume Next

cf1 = ws1.Cells(i, c).FormulaLocal
cf2 = ws2.Cells(r, c).FormulaLocal

On Error GoTo 0

If cf1 <> cf2 Then
dupRow = False
Exit For

Else
dupRow = True
End If

Next c

If dupRow Then
dupCount = dupCount + 1
ws1.Range(ws1.Cells(i, 1), ws1.Cells(i, maxC)).Select
Selection.Copy
Worksheets("Sheet3").Select
Worksheets("Sheet3").Range(Worksheets("Sheet3").Cells(lr3, 1), Worksheets("Sheet3").Cells(lr3, maxC)).Select
Selection.PasteSpecial
lr3 = lr3 + 1

ws1.Select
For t = 1 To maxC
ws1.Cells(i, t).Interior.ColorIndex = 19
ws1.Cells(i, t).Select
Selection.Font.Bold = True
Next t
End If
Next r
Next i

Application.StatusBar = "Formatting the report..."
'Columns("A:IV").ColumnWidth = 10
m = dupCount
Application.StatusBar = False
Application.ScreenUpdating = True

MsgBox m & " Rows contain same values!", vbInformation, _
"Compare " & ws1.Name & " with " & ws2.Name

End Sub

Ekipa z  Vertical Horizons  wielkie dzięki

 

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

utworzone przez | 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

Excel Klawissz 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