tady jeden pokus :-)
Dim rd0 As Single
Dim rd1 As Single
Dim rd2 As Single
Dim sl As Single
rd1 = 1
rd2 = 1
Do While Cells(rd1, 1) <> ""
sl = 5
List2.Cells(rd2, 1) = Cells(rd1, 1)
List2.Cells(rd2, 2) = Cells(rd1, 2)
List2.Cells(rd2, 3) = Cells(rd1, 3)
List2.Cells(rd2, 4) = Cells(rd1, 4)
List2.Cells(rd2, sl) = Cells(rd1, 5)
sl = sl + 1
rd0 = rd1
Do While Cells(rd0, 1) = Cells(rd1, 1) And Cells(rd0, 2) = Cells(rd1, 2)
If List2.Cells(rd2, sl - 1) <> Cells(rd1, 5) Then
List2.Cells(rd2, sl) = Cells(rd1, 5)
sl = sl + 1
End If
rd1 = rd1 + 1
Loop
rd2 = rd2 + 1
Loop
List2.Activate
M@citovat
Dim rd0 As Single
Dim rd1 As Single
Dim rd2 As Single
Dim sl As Single
rd1 = 1
rd2 = 1
Do While Cells(rd1, 1) <> ""
sl = 5
List2.Cells(rd2, 1) = Cells(rd1, 1)
List2.Cells(rd2, 2) = Cells(rd1, 2)
List2.Cells(rd2, 3) = Cells(rd1, 3)
List2.Cells(rd2, 4) = Cells(rd1, 4)
List2.Cells(rd2, sl) = Cells(rd1, 5)
sl = sl + 1
rd0 = rd1
Do While Cells(rd0, 1) = Cells(rd1, 1) And Cells(rd0, 2) = Cells(rd1, 2)
If List2.Cells(rd2, sl - 1) <> Cells(rd1, 5) Then
List2.Cells(rd2, sl) = Cells(rd1, 5)
sl = sl + 1
End If
rd1 = rd1 + 1
Loop
rd2 = rd2 + 1
Loop
List2.Activate
M@citovat