Création de feuilles individuelles à partir d'une BDD en fonction d'un filtre

[exene]

Bonjour,

Je vous expose mon souci.

Je dispose d'une base de données et d'un onglet modèle. Je souhaiterais créer des feuilles individuelles à partir du modèle en ajoutant un critère obtenu par un filtre (ici le numéro de la semaine)

Ci-joint le fichier


@+

 

[kjin]

Re : Création de feuilles individuelles à partir d'une BDD en fonction d'un filtre

bonjour,

Sub FiltreSemaine()
Dim rng As Range
Dim wsTemp As Worksheet, tabId, tablo
Dim wsNew$
With Sheets("BDD")
    If .Range("A2") = "" Then Exit Sub
    Set rng = .Range("A1:G1" & .Range("A65000").End(xlUp).Row)
    tabId = Application.Transpose(.Range("Identifiants").Value)
End With
Application.ScreenUpdating = False
Set wsTemp = Sheets.Add
With wsTemp
    .Name = "Temp"
    .Range("A1") = "Semaine"
    .Range("A2") = [Semaine]
    .Range("B1") = "Identifiant"
    For i = 1 To UBound(tabId)
        .Range("B2") = tabId(i)
        rng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("A1:B2"), _
                    CopyToRange:=.Range("A5"), Unique:=False
        If .Range("A6") <> "" Then
            tablo = .Range("B6:G6" & .Range("B65000").End(xlUp).Row).Value
            wsNew = tabId(i) & "-Sem" & [Semaine]
            DelFeuille wsNew
            Sheets("Modèle").Copy after:=Sheets(Sheets.Count)
            With ActiveSheet
                .Name = wsNew
                .Range("A5") = [Semaine]
                .Range("B7").Resize(UBound(tablo, 1), UBound(tablo, 2)) = tablo
            End With
        End If
        .Range("A5:G65000").Clear
    Next
End With
Application.DisplayAlerts = False
wsTemp.Delete
Application.DisplayAlerts = True
Sheets("BDD").Activate
End Sub

Sub DelFeuille(Feuille As String)
On Error Resume Next
Set ws = Sheets(Feuille)
If Not ws Is Nothing Then
    Application.DisplayAlerts = False
    ws.Delete
    Application.DisplayAlerts = True
End If
On Error GoTo 0
End Sub

A+
kjin

 

[JCGL]

Re : Création de feuilles individuelles à partir d'une BDD en fonction d'un filtre

Bonjour à tous,
Salut Pascal,
Salut Kjin,

Un essai mais sur les semaines comme je l'ai compris dans l'énoncé.
Je ne gère pas l'existence d'une semaine déjà traitée.

A++
A + à tous

 

[kjin]

Re : Création de feuilles individuelles à partir d'une BDD en fonction d'un filtre

Re, salut JC,

Un essai mais sur les semaines comme je l'ai compris dans l'énoncé.

Je me suis posé la question, mais comme je lis "individuelle"
S'il s'agit de créer une feuille par semaine

Sub FiltreSemaine()
Dim rng As Range, wsNew$
Application.ScreenUpdating = False
With ActiveSheet
    .Range("A1:G1" & .Range("A65000").End(xlUp).Row).Sort Key1:=Range("A2"), _
            Order1:=xlAscending, Key2:=Range("C2"), Order2:=xlAscending, Header:=xlGuess
    .AutoFilterMode = False
    .Range("A1").AutoFilter Field:=1, Criteria1:=[Semaine]
    With .AutoFilter.Range
        On Error Resume Next
        Set rng = .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count) _
            .SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        If Not rng Is Nothing Then
            wsNew = "Semaine" & [Semaine]
            DelFeuille wsNew
            Sheets("Modèle").Copy after:=Sheets(Sheets.Count)
            With ActiveSheet
                .Name = wsNew
                .Range("A5") = [Semaine]
                .Range("B7").Resize(rng.Rows.Count, rng.Columns.Count) = rng.Value
            End With
        End If
    End With
    .AutoFilterMode = False
    .Activate
End With
End Sub

Sub DelFeuille(Feuille As String)
On Error Resume Next
Set ws = Sheets(Feuille)
If Not ws Is Nothing Then
    Application.DisplayAlerts = False
    ws.Delete
    Application.DisplayAlerts = True
End If
On Error GoTo 0
End Sub

A+
kjin

 

[exene]

Re : Création de feuilles individuelles à partir d'une BDD en fonction d'un filtre

Bonsoir,

Je viens de lire vos messages. Je vous remercie de votre aide. Je fais des essais dès demain au travail.

Encore merci

@+