Try changing:
Set rng = Sheet1.Range("A4:A" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row)
To:
Set rng = Sheet1.ListObjects("Tabelle1").ListColumns("ID").DataBodyRange.SpecialCells(xlCellTypeConstants)
On thing I will say is that I think it would be better not to have the large blank section of the table (down to row 500) - instead trim the table to the size of the data - the table formatting will extend when you add data anyway. If you do remove the blank section of the table then you could remove the SpecialCells bit from the code to make:
Set rng = Sheet1.ListObjects("Tabelle1").ListColumns("ID").DataBodyRange
Hope this helps