MS Excel

Až to bude mít jasnou logiku...citovat

list1 zamen nazew na: Data
list2 zamen nazew na: Zmeny
kod:

Sub Zamena()
Dim Spolecnost As String
Dim Zeme As String
Dim Adres As String
Dim TypZmeny As String
Dim Kapital As Long
Dim Data As Worksheet
Dim Zmeny As Worksheet
Dim i As Long
Dim j As Long

Set Data = ThisWorkbook.Sheets("Data")
Set Zmeny = ThisWorkbook.Sheets("Zmeny")
For i = 2 To LastUsedRow(Data, "A")
Spolecnost = Data.Cells(i, "A")
Zeme = Data.Cells(i, "B")
Adres = Data.Cells(i, "C")
Kapital = Data.Cells(i, "D")

For j = 2 To LastUsedRow(Zmeny, "A")
If Zmeny.Cells(j, "C") = Spolecnost Then
'kdyz kod znajde stejne data v slupcu E podmeni data na te ze slupca F
If Zmeny.Cells(j, "E") = Zeme Then Zeme = Zmeny.Cells(j, "F")
If Zmeny.Cells(j, "E") = Adres Then Adres = Zmeny.Cells(j, "F")
If Zmeny.Cells(j, "E") = Kapital Then Kapital = Zmeny.Cells(j, "F")
TypZmeny = Zmeny.Cells(j, "D")
'pokud kod nasel Spolecnost ne musi pokracovat
Exit For
Else:
TypZmeny = "bez zmen"
'nebo
'TypZmeny = ""
End If
Next j
'zapisujemy zmeny
Data.Cells(i, "B") = Zeme
Data.Cells(i, "C") = Adres
Data.Cells(i, "D") = Kapital
Data.Cells(i, "D") = Kapital
Data.Cells(i, "F") = TypZmeny

Next i

Set Data = Nothing
Set Zmeny = Nothing

End Sub

Function LastUsedRow(ws As Worksheet, column As String) As Long
LastUsedRow = ws.Cells(ws.Rows.Count, column).End(xlUp).Row
End Functioncitovat

Zdravím :) tak makro funguje v případě, kdy nedojde k více změn u jedné společnosti. Pokud je zaznamenáno více změn u jedné společnosti (například změna podílu a změna základního kapitálu), makro nefunguje. Bylo by možné kód (viz výše - od nunus67) poupravit tak, aby se přepsaly všechny změny, popřípadě když dojde ke změně stejné položky u jedné společnosti (dvakrát za sebou se změní základní kapitál) brát tu nejaktuálnější? Šlo by dále změněnou hodnotu, která byla přepsána z listu Zmeny do listu Data zvýraznit pro aktuální měsíc červeným písmem? (př: v dubnu by byly červeným písmem zvýrazněné změny provedené v dubnu).citovat