vím, že toto téma tu je mockrát, ale ani jedno se přímo nehodí na můj problém, takže se předem omlouvám za založení nového tématu.
Používám makro k poorvnání dvou excel souborů, které při shodě přepíše hodnotu z zdrojového souboru do cílového. Jelikož nejsem odborník, chtěl jsem poprosit, zda by šlo do tohoto makra dodělat aby při shodě se daná aktualizovaná buňka obarvila barvou??? Případně jak by dané makro vypadalo upravené?
Předem mockrát děkuji
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.xls").Worksheets(1)
Set cilsesit = Workbooks("cil.XLS").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
