Kód: Vybrat vše
Sub Porovnej()
Dim BlkA As Range, BlkB As Range
Dim CllA As Range, CllB As Range
Dim zdrojsesit As Object, cilsesit As Object
Dim frstAddr As String
Dim shoda, radek As Integer
On Error GoTo err
' definovani bloku bunek na listech (sesit, list, oblast)
Set zdrojsesit = Workbooks("zdroj.xlsx").Worksheets(1)
Set cilsesit = Workbooks("cil.xlsm").Worksheets(1)
zdrojsesit.Activate
Set BlkA = zdrojsesit.Range(("a1:a") & Cells(Rows.Count, "a").End(xlUp).Row)
cilsesit.Activate
Set BlkB = cilsesit.Range(("a1:a") & Cells(Rows.Count, "a").End(xlUp).Row)
shoda = 0 ' pocet shod
Application.ScreenUpdating = False
' prochazet BlkA
For Each CllA In BlkA.Cells
' prohledavat BlkB
With BlkB
Set CllB = .Find(CllA.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not CllB Is Nothing Then ' pri shode porovnat sloupce
frstAddr = CllB.Address
Do
If CllA.Offset(0, 0).Value = "" Then
GoTo dalsi ' skoc na dalsi hodnotu v bloku A
End If
If CllB.Offset(0, 0).Value = CllA.Offset(0, 0).Value Then ' pri shode zkopiruj
With zdrojsesit
.Rows(CllA.Row).Copy
End With
With cilsesit
.Rows(CllB.Row).PasteSpecial
End With
Application.CutCopyMode = False
shoda = shoda + 1
GoTo dalsi ' skoc na dalsi hodnotu v bloku A
End If
Set CllB = .FindNext(CllB)
Loop While CllB.Address <> frstAddr
End If
dalsi:
End With
Next CllA
Application.ScreenUpdating = True
MsgBox " Uff, nasel jsem " & shoda & " shod.", vbInformation
' odstranit objektove promenne
Set zdrojsesit = Nothing
Set cilsesit = Nothing
Set CllB = Nothing
Set CllA = Nothing
Set BlkB = Nothing
Set BlkA = Nothing
End
err:
MsgBox " !! Neni otevřen jeden ze sešitů !! ", vbCritical
End Sub