Organiser tableau vba

Option Explicit

Sub Classement()
Dim ws As Worksheet
Dim rg As Range, rgC As Range
Dim Ref As String, sDate As String
Dim wRow As Integer, Tot As Double, i As Integer

Application.ScreenUpdating = False

Set ws = ThisWorkbook.Sheets("of")  'feuille contenant les données
Set rg = ws.Range("A4")     'Plage de début

Ref = ""
Do Until IsEmpty(rg)
    If rg.Value <> Ref Then
        Ref = rg.Value   'nouvelle référence
        wRow = rg.Row    'ligne pour écrire
    End If
    sDate = rg.Offset(0, 1)
    
    Set rgC = ws.Range("D3")
    Do Until IsEmpty(rgC)
        If rgC = sDate Then
            Cells(wRow, rgC.Column) = rg.Offset(0, 2)   'Quantité
        End If
    Set rgC = rgC.Offset(0, 1)   ' on déplace de 1 colonne
    Loop
Set rg = rg.Offset(1, 0)
Loop

'Maintenant on efface, en partant de la fin (c'est plus facile)
Set rg = ws.Range("A60000").End(xlUp)

Do Until rg.Row = 3
    If rg.Offset(-1, 0) = rg Then
        rg.Interior.ColorIndex = 3
        Rows(rg.Row).EntireRow.Delete
    End If

Set rg = rg.Offset(-1, 0)   'on recule de 1 ligne
Loop

Application.ScreenUpdating = True

End Sub

'Maintenant on efface, en partant de la fin (c'est plus facile)
Set rg = ws.Range("A60000").End(xlUp)

Do Until rg.Row = 3
    Tot = 0
    For i = 3 To 250
        Tot = Tot + rg.Offset(0, i)
    Next i
    
    Set rg = rg.Offset(-1, 0)
   
    If Tot = 0 Then Rows(rg.Row + 1).EntireRow.Delete
Loop

Application.ScreenUpdating = True