Tak sem se v tom kódu šťoural. Vyzkoušej funkci

Sub Kopiruj()

Application.ScreenUpdating = False
    
    List7.Activate
    List7.Cells(Cells(1000, 1).End(xlUp).Row, 1).Select
    posledni = ActiveCell.Address(False, False)
    Range(Cells(4, 1), posledni).ClearContents
    List3.Activate

For i = 1 To 1000

If Cells(i, 3).Value = "Sklad 01" Then

    Cells(i, 1).Copy
    List7.Activate
    List7.Cells(Cells(1000, 1).End(xlUp).Row + 1, 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues
    Selection.NumberFormat = "d mmmm yyyy"
    List3.Activate

    Hodnota = Cells(i, 2).Value
    Cislo = Abs(Hodnota)
    List7.Activate
    List7.Cells(Cells(1000, 1).End(xlUp).Row, 2).Select
    Selection.Cells.Value = Cislo
    Selection.NumberFormat = "# Ks"
    
    List7.Cells(Cells(1000, 1).End(xlUp).Row, 3).Select
    Selection.Cells.Value = "zboží"
    List3.Activate

End If
Next i

Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub