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