Excel - Tworzenie makra - sortowanie i przenoszenie między komórkami

If Unikaty3(i - 1) = Unikaty3(i) Then

 If Unikaty3(i - 1) = Unikaty3(i) And Unikaty1(i - 1) = Unikaty1(i) Then

Option Explicit

Sub Dostosuj()
Dim lista As Variant, ileWrs As Integer, idx As Integer
Dim OstW As Long, tbl() As Variant, i As Long, j As Integer
Dim Unikaty1 As New Collection, Unikaty2 As New Collection
Dim Unikaty3 As New Collection, Unikaty4 As New Collection
Dim test As New Collection, odWiersza As Integer

With ThisWorkbook.Worksheets("Arkusz1")
  OstW = .Range("A1:C2").End(xlDown).Row
  Application.ScreenUpdating = False
  Sortuj (OstW)   'sortowanie
  TmToStr (OstW)  'zmiana godz na string kol.D
  lista = .Range("A1:D" & OstW)
  
  'do kolekcji nie można dodać powtarzającej się warości,
  'więc sobie przepiszemy
  For i = UBound(lista, 1) To 1 Step -1
    On Error Resume Next
    test.Add lista(i, 1) & lista(i, 2), CStr(lista(i, 1) & lista(i, 2))
  
    If Err = 0 Then
      Unikaty1.Add lista(i, 1)
      Unikaty2.Add lista(i, 2)
      Unikaty3.Add lista(i, 3)
      Unikaty4.Add lista(i, 4)
    End If
    On Error GoTo 0
  Next
  
  'umieścimy wartości w tabeli dwuwymiarowej
  'zmieniając kolejność dla poj. wiersza
  ReDim tbl(4, Unikaty1.Count)

  tbl(1, 1) = Unikaty1(1)
  tbl(2, 1) = Unikaty2(1)
  tbl(3, 1) = Unikaty3(1)
  tbl(4, 1) = Unikaty4(1)
  idx = 1
  
  For i = 2 To Unikaty1.Count
    If Unikaty3(i - 1) = Unikaty3(i) And Unikaty1(i - 1) = Unikaty1(i) Then
      tbl(2, idx) = Unikaty2(i) & Chr(10) & tbl(2, idx)
      tbl(4, idx) = Unikaty4(i) & Chr(10) & tbl(4, idx)
    Else
      idx = idx + 1
      tbl(1, idx) = Unikaty1(i)
      tbl(2, idx) = Unikaty2(i)
      tbl(3, idx) = Unikaty3(i)
      tbl(4, idx) = Unikaty4(i)
    End If
  Next
End With

'i wpisujemy do arkusza
ileWrs = idx
idx = 1
odWiersza = 1   'gdzie rozpoczyna się tabelka wynikowa

With Sheets(3)
  .Cells.ClearContents
  For i = ileWrs + odWiersza - 1 To odWiersza Step -1
    For j = 1 To 4
      .Cells(i, j) = tbl(j, idx)
    Next
    idx = idx + 1
  Next
  .Activate
End With

Application.ScreenUpdating = True
End Sub