Macro pour creer feuille en fonction du contenu en Colonne A

[fredh]

Bonjour
J'ai un fichier xls qui en colonne A contient des numero de serie.
Ce fichier contient les valeur de pieces produites.
On peut donc retrouver plusieurs fois le meme numero de serie.
J'aimerai regrouper les meme numero de serie dans chaque fois une feuille qui a le nom du num de serie.
Dans mon fichier d'origine j'ai formatter les colonnes, il faudrait donc copier la 1er feuille la nommer en fonction du numero de serie et effacer les numero de serie (la ligne complete) non necessaire a cette nouvelle feuille. et ainsi de suite.
Pour faciliter les chose dans la feuille d'origine il faudrait "scinder" le numero de serie en 3 (utiliser le "-" comme separateur"). en effet j'ai des numeru de la forme codebarre-numserie-nid.
Il faudrait donc creer 3 colonne : la 1er "codebarre", la 2em "numserie" et la 3em "nid".

Mes connaissance en vba sont trop limiter pour realiser cela, je fait donc appel aux bonnes ames de ce forum.

Merci d'avance pour les coup de pouce ou remarques pouvant m'aider

 

[fredh]

Re : Macro pour creer feuille en fonction du contenu en Colonne A

Bonjour Pierre Jean

voila les modif que j'ai apporter pour integrer le quadrillage

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

Je je peut encore me permettre d´`etendre la demande a une feuille d'index:
J'aimerai que la 1er feuille soit une feuille qui recapitule le nom de toutes les feuille presentes.
J'aimerai aussi creer un hyperliens vers ces feuille.

Voila j'ai deja une idées je vais donc creuser un petit peu mais plus aujourd'huit.....et je te tiendrait au courant

 

[fredh]

Re : Macro pour creer feuille en fonction du contenu en Colonne A

Pour la creation d'index et les nom des feuilles
J'ai ceci pondu ceci

    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

il me reste a trouver comment creer les hyperliens....
@+