Excel97 : comment faire un genre d' abcdaire automatique ?

Private Sub Workbook_SheetActivate(ByVal Sh As Object)

Dim ori(), dest(), Init As String, i As Long
Dim j As Long, k As Long, N As Long
Dim i11 As Long, i12 As Long, i21 As Long, i22 As Long

If Len(Sh.Name) <> 1 Then Exit Sub
Init = Sh.Name & "*"

With Sheets("test")
  ori = Application.WorksheetFunction.Transpose _
        (.Range("1:1").CurrentRegion.Value)
  i11 = LBound(ori, 1): i12 = UBound(ori, 1)
  i21 = LBound(ori, 2): i22 = UBound(ori, 2)
End With

ReDim dest(i11 To i12, i21 To i22)
N = i21 - 1

For i = i21 To i22
  If ori(2, i) Like Init Then
    N = N + 1
    For j = i11 To i12
      dest(j, N) = ori(j, i)
    Next j
  End If
Next i

With Sh
  .Cells.Clear
  If N > i21 - 1 Then
    ReDim Preserve dest(i11 To i12, i21 To N)
    .Range("A1").Resize(N - i21 + 1, i12 - i11 + 1).Value _
        = Application.WorksheetFunction.Transpose(dest)
    Sheets("test").Range("1:" & i12).Copy
    .Range("A1").CurrentRegion.PasteSpecial xlPasteFormats
    .Range("A1").CurrentRegion.PasteSpecial xlPasteColumnWidths
    .Range("A1").Select
  End If
End With

End Sub

Private Sub Worksheet_Deactivate()

Dim Init As String, i As Long
Dim j As Long, k As Long
Dim i11 As Long, i12 As Long

Application.ScreenUpdating = False

For i = 1 To Sheets.Count
  If Len(Sheets(i).Name) = 1 Then Sheets(i).Cells.Delete
Next i

With Sheets("test")
  i11 = 1: i12 = Range("A" & .Rows.Count).End(xlUp).Row
  For i = i11 To i12
    Init = Left(.Range("B" & i), 1)
    If IsNumeric(Init) Then Init = "#"
    k = Sheets(Init).Range("B" & Rows.Count).End(xlUp).Row
    If Sheets(Init).Range("B" & k) <> "" Then k = k + 1
    .Rows(i).Copy Sheets(Init).Rows(k)
  Next i
End With

For i = 1 To Sheets.Count
If Len(Sheets(i).Name) = 1 Then Sheets(i).Cells.EntireColumn.AutoFit
Next i

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