Mon "For each Cell" s'arrete...

Set Plage = ActiveSheet.UsedRange.Rows("2:" & ActiveSheet.UsedRange.Rows.Count)

Option Explicit
Sub test()
Dim c As Range, p As Range
Set p = Sheets("Feuil1").UsedRange
For Each c In p.Offset(1).Resize(p.Rows.Count - 1)
    'ton code
Next c
End Sub

Option Explicit
Sub CRHEBDO()

Dim r As Integer
Dim c As Integer
Dim i As Integer
Dim d As Integer
Dim s As Integer
Dim Cell As Range
Dim Plage As Range


Set Plage = ActiveSheet.UsedRange
 
 For Each Cell In Plage.Offset(1).Resize(Plage.Rows.Count - 1)
    If Not IsEmpty(Cell) Then
            c = Cell.Column
            s = ActiveSheet.Name
            d = Cells(1, c + 1).Value
            
            'collage de la donnée
            i = Sheets("GLOBAL").UsedRange.Rows.Count + 1
            Sheets("GLOBAL").Range("A" & i).Value = s
            Sheets("GLOBAL").Range("B" & i).Value = d
            Sheets("GLOBAL").Range("C" & i).Value = Cell.Value
            
          End If
  Next Cell
  
End Sub

Set Plage = ActiveSheet.UsedRange
 
 For Each Cell In Plage.Offset(1).Resize(Plage.Rows.Count - 1)

Set Plage = ActiveSheet.UsedRange.Rows("2:" & ActiveSheet.UsedRange.Rows.Count)
 
 For Each Cell In Plage