Macro pour creer feuille en fonction du contenu en Colonne A

Sub Abfrage()
Dim coul
coul = Array(2, 36, 34, 35, 39)
Dim n As Integer, m As Integer, ligne As Integer, ncoul As Integer, nn As Integer, nnn As Integer
Dim x As Integer, y As Integer, z As Integer, lmax As Integer
Dim t As Variant
Dim Org_Sheet As String
Org_Sheet = ActiveSheet.Name
Application.ScreenUpdating = False
Dim numserie As Collection
Set numserie = New Collection
ligne = 2
Worksheets.Add.Name = "temp"
With Sheets(Org_Sheet)
For n = 2 To .Range("A65536").End(xlUp).Row
t = Split(.Range("A" & n), "-")
Range("A" & ligne) = t(0)
Range("B" & ligne) = t(1)
Range("C" & ligne) = t(2)
ligne = ligne + 1
Next n
.Range("B2:L" & .Range("A65536").End(xlUp).Row).Copy Destination:=Range("D2")
End With
With Sheets("temp")
 For n = 2 To .Range("B65536").End(xlUp).Row
 On Error Resume Next
    numserie.Add .Range("B" & n), CStr(.Range("B" & n))
 On Error GoTo 0
 Next n
 For n = 1 To numserie.Count
  Worksheets.Add.Name = numserie(n)
  ligne = 2
  Sheets(Org_Sheet).Range("B1:L1").Copy Destination:=Range("D1")
  Range("A1") = "Codebarre"
  Range("B1") = "Seriennumber"
  Range("C1") = "Nest"
  Range("A1:C1").Select
  With Selection.Interior
        .ColorIndex = 15
        .Pattern = xlSolid
  End With
  Range("A2").Select
  ActiveWindow.FreezePanes = True
 
  With Sheets("temp")
  For m = 2 To .Range("B65536").End(xlUp).Row
     If .Range("B" & m) = numserie(n) Then
       .Range("A" & m & ":L" & m).Copy Destination:=Cells(ligne, 1)
       ligne = ligne + 1
     End If
  Next m
  End With
 Range("A1:L" & Range("A65536").End(xlUp).Row).AutoFilter
 Next n
End With
Application.DisplayAlerts = False
Sheets("temp").Delete
Sheets(Org_Sheet).Delete
For nn = 1 To Sheets.Count
If Sheets(nn).Name <> Org_Sheet Then
 x = Sheets(nn).Range("IV1").End(xlToLeft).Column
 For z = 1 To x
   For y = 1 To Sheets(nn).Cells(65536, z).End(xlUp).Row
     If lmax < Len(Sheets(nn).Cells(y, z).Value) Then
        lmax = Len(Sheets(nn).Cells(y, z).Value)
        If LCase(Sheets(nn).Cells(y, z).Value) <> Sheets(nn).Cells(y, z).Value Then
           lmax = 1.2 * lmax
        End If
     End If
   Next y
   Sheets(nn).Columns(z).ColumnWidth = lmax
   lmax = 0
 Next z
 Sheets(nn).Range("A2:L" & Sheets(nn).Range("A65536").End(xlUp).Row).Sort Key1:=Sheets(nn).Range("H2"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
[COLOR=red]'Fred
 With Sheets(nn).Range("A1:L" & Sheets(nn).Range("A65536").End(xlUp).Row)
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    With .Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 1
    End With
    With .Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 1
    End With
    With .Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 1
    End With
    With .Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 1
    End With
    With .Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 1
    End With
    With .Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = 1
    End With
End With
'Fred
[/COLOR]
ncoul = 0
Sheets(nn).Range("A2:L2").Interior.ColorIndex = coul(ncoul)
 For nnn = 3 To Sheets(nn).Range("F65536").End(xlUp).Row
 If Sheets(nn).Range("H" & nnn) - Sheets(nn).Range("H" & nnn - 1) > 0.000025 Then ncoul = ncoul + 1
 Sheets(nn).Range("A" & nnn & ":L" & nnn).Interior.ColorIndex = coul(ncoul)
 Next nnn
 For nnn = 1 To Sheets(nn).Range("L65536").End(xlUp).Row
    If Sheets(nn).Range("L" & nnn) = 0 Then
      Sheets(nn).Range("L" & nnn).Interior.ColorIndex = 3
      Sheets(nn).Range("J" & nnn).Interior.ColorIndex = 3
      Sheets(nn).Range("G" & nnn).Interior.ColorIndex = 3
    End If
 Next nnn
 Sheets(nn).Rows.RowHeight = 12.75
 End If
Next nn
Application.ScreenUpdating = True
End Sub

    Worksheets.Add.Name = "Index"
    For i = 1 To Sheets.Count
    If Sheets(i).Name <> "Index" Then
        Range("A1").Cells(Range("A65536").End(xlUp).Row + 1, 1).Value = Sheets(i).Name
    End If
    Next i