Couper coller en créant un nouvel onglet

Bonsoir tout le monde

J'ai un souci avec un code que je voudrais adapter afin de générer des onglets à partir d'une base de donnée extraite d'un fichier.

J'ai une feuille "données" qui me sert de base pour créer, et générer des feuilles issues du modèle PB XxXxX

Le code de la macro me génère bien toutes les copies en fonction de la colonne A

Mon souci, c'est que dans chaque nouvel onglet créer, j'ai besoin que les données des colonnes B, C, D et E soit en même

temps copier dans la feuille qui correspond à son numéro en F35. (ou autre mais je ne sais pas comment)

Je doit faire l'extraction des données en commençant par le bas car le nombre de lignes peu varier au maximum de 1 à 12.

Je joint un fichier avec la macro

PS EN PLLUS SI QUELQU'UN ARRIVE ME INSERER LES ESPACES DANS CETTE FORMULES

ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[5], RC[6], RC[3], RC[4])"

CA RENDRAIT MES FICHES PLUS PROPRES

D'avance je vous remercie de l'attention que vous porterez à ma demande

Je ne suis pas sur que le fichier soit passer alors au cas ou je le renvoi

encore merci de votre attention

Désolé voici le fichier je l'avais laissé en *.XLMs

bonsoir,

une proposition pour la création des différents onglets.

Sub test()
    Set wsd = Sheets("données")
    For i = 1 To wsd.Cells(Rows.Count, 4).End(xlUp).Row
        If wsd.Cells(i, 2) <> "" Then
        On Error Resume Next
        'application.displayalerts=false
        Sheets(wsd.Cells(i, 1)).Delete
        'application.displayalerts=true
        On Error GoTo 0
            Set ws = Worksheets.Add
            ws.Name = wsd.Cells(i, 2)
            lig = 0
        End If
        lig = lig + 1
        wsd.Range("B" & i & ":E" & i).Copy ws.Cells(lig, "F")
    Next i
End Sub

pour ce qui est de ton autre question

ActiveCell.FormulaR1C1 = "=CONCATENATE(RC[5]," & """ """ & ",RC[6]," & """ """ & ",RC[3]," & """ """ & ",RC[4])"

Bonsoir,

Une autre proposition

A+

Bonsoir tout le monde

Merci de votre attention et du temps que vous me consacrer

tout fonctionne et je vous remercie, vous, m'otez une grosse épine du pied c'est vraiment super

il me reste un truc

comment faire pour ne sélectionner que les feuilles crées (donc pas le modèle ni les données) afin de fixer le texte et supprimer

les ligne 35 à 46

d'avance merci

Bonjour,

Sub Test2()
Dim Ws As Worksheet
    Application.ScreenUpdating = False
    For Each Ws In Worksheets
        If Ws.Name <> "Données" And Ws.Name <> "PB XxXxX" Then
            Ws.Range("F35:K46").ClearContents
        End If
    Next Ws
End Sub

A+

Re bonsoir

Merci pour la réactivité frangy

Ou est ce que j'insère cette partie de code dans ce que tu viens de m'envoyer?

Range("C7:D31").Select

Selection.Copy

Range("C7:D7").Select

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

:=False, Transpose:=False

cela me permet de copier les valeurs contenue dans les cellules afin de fixer le texte avant suppression des données

encore merci pour la disponibilité

Bonjour,

Si le traitement n’est pas indépendant de l’autre procédure, tu peux l’intégrer ainsi :

Sub Test()
Dim C As Range, MaPlage As Range, CelDebut As Range, CelFin As Range
Dim WsS As Worksheet, WsC As Worksheet
Dim Ligne As Long

    Application.ScreenUpdating = False

    Set WsS = ActiveWorkbook.Worksheets("Données")
    WsS.Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    WsS.Columns("B:B").Copy
    ActiveSheet.Paste Destination:=WsS.Columns("A:A")
    Application.CutCopyMode = False

    Set MaPlage = WsS.Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
    MaPlage.Sort Key1:=MaPlage.Cells(1, 1), Order1:=xlDescending, Header:=xlNo

    Set MaPlage = WsS.Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
    For Each C In MaPlage
        'on vérifie si la feuille existe déjà
        On Error Resume Next
        Set WsC = Worksheets(C.Value)
        On Error GoTo 0
        'si la feuille n'existe pas alors WsC est vide (nothing), on poursuit :
        If WsC Is Nothing Then
            'on copie le modèle en dernier
            Worksheets("PB XxXxX").Copy After:=Worksheets(ThisWorkbook.Sheets.Count)
            With Worksheets(ThisWorkbook.Sheets.Count)   'avec l'onglet créé
                .Name = C.Value     'on renomme
                'on remplit notre modèle comme on veut...
                .Range("F2") = C.Value
                Set CelDebut = WsS.Columns(2).Find(C, , xlValues, xlWhole).Offset(0, 1)
                Set CelFin = CelDebut.End(xlDown).Offset(-1, 4)
                WsS.Range(CelDebut, CelFin).Copy .Range("F35")
                .Range("C7:D31").Copy
                .Range("C7:D7").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                    :=False, Transpose:=False
                .Range("F35:K46").ClearContents
            End With
        End If
        Set WsC = Nothing
    Next C

    Set MaPlage = Nothing: Set WsS = Nothing

End Sub

A+

Bonjour tout le monde

Un grand merci à frangy

tout fonctionne impec

je clôture le post

mais i'll be back