Remplir une fiche avec des donnée en quantité variable

Bonsoir tout le monde

J'ai un code dans fichier avec une feuille donnée qui me permet des créer des fiches en fonction d'adresses en nombre variable à insérer dans un modèle.

Pour l'instant le code crée les feuilles dont j'ai besoin en fonction de la base de donnée et colle en dessous de mon tableau

les adresses et renseignements que je veux implanter dans chaque feuille.

La macro fais un collage spécial qui fixe le texte à la place des formules.

n'y a t il pas la possibilité d'implanté directement les données au bon endroit? car le copiage spécial plante l'extraction en CSV en me collant des cellules vide; et de supprimer la fiche "immeubles"

Je joint un fichier xls qui doit le rester (pas de xlsm)

D'avance merci pour votre disponibilité et votre aide

Bonjour Eoole, bonjour le forum,

Peut-être comme ça :

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
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(3).Find(C, , xlValues, xlWhole).Offset(0, 1)
            Set CelFin = CelDebut.Offset(0, -1).End(xlDown).Offset(-1, 2)
            WsS.Range(CelDebut, CelFin).Copy .Range("F35")
        End With
    End If
    Set WsC = Nothing
Next C
Set MaPlage = Nothing: Set WsS = Nothing
End Sub

Bonjour à tous

Merci pour ta réponse ThauThème, mais je pense que je me suis mal expliquer

Je cherche à implanter directement les renseignements de la feuille "Données" dans les bons emplacements des feuilles crées au lieu de les mettre en bas et qu'ils apparaissent grâce à des formules.

Dans le même principe que la cellule"F2"

mon souci c'est que des fois la feuille modèle va contenir une adresse et son code, mais la feuille suivante va en contenir 12

j'ai besoin de supprimer toutes les formules des feuilles

merci de votre disponibilité pour un néophyte en VBA

Bonjour Eole, bonjour le forum,

Commence par effacer toutes le cellules contenant des formules dans l'onglet modèle PB XxXxX puis essaie le code commenté ci-dessous :

Sub Macro1()
Dim D As Worksheet 'déclare la variable D (onglet Données)
Dim TC As Variant 'déclare la variable TC (Tableau de Cellules)
Dim I As Integer 'déclare la variable I (Incrément de ligne)
Dim NO As Worksheet 'déclare la variable NO (Nouvel Onglet)
Dim DEST As Range 'déclare la variable Dest (Cellule de DESTination)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set D = Sheets("Données") 'définit l'onglet D
TC = D.Range("A1").CurrentRegion 'féfinit le tableau de cellules TC
For I = 1 To UBound(TC, 1) 'boucle sur toutes les lignes I du tableau de cellules TC
    If TC(I, 2) = "Immeubles" Then Exit Sub 'si la valeur ligne I colonne 2 est egale à "Immeubles", sort de la procédure
    If TC(I, 2) <> "" Then 'condition 1 : si la valeur ligne I colonne 2 de TC n'est pas vide
        On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
        Set NO = Sheets(TC(I, 2)) 'définit l'onglet NO (génère une erreur si cet onglet n'existe pas
        If Err = 0 Then 'condition 2 : si aucune erreur n'a été générée
            Application.DisplayAlerts = False 'masque les message de l'application Excel
            NO.Delete 'supprime l'anciel onglet (facultatif mais c'est au cas ou...)
            Application.DisplayAlerts = True 'affiche les message de l'application Excel
        Else 'sinon (si une erreur a été générée
            Worksheets("PB XxXxX").Copy After:=Worksheets(ThisWorkbook.Sheets.Count) 'copie l'onglet "PB XxXxX" en dernière position
            Set NO = ActiveSheet 'définit le nouvel onglet NO
        End If 'fin de la condition 2
        On Error GoTo 0 'annule la festion des erreurs
        NO.Name = TC(I, 2) 'définit le nom du nouvel onglet NO
        NO.Range("F2").Value = TC(I, 2) 'renvoie dans la cellluel F2 de NO la valeur ligne I colonne 2 de TC
        NO.Range("C7").Value = TC(I, 3) 'renvoie dans la cellule C7 de NO la valeur ligne I colonne 3 de TC
        NO.Range("C8").Value = TC(I, 4) 'renvoie dans la cellule C8 de NO la valeur ligne I colonne 4 de TC
        NO.Range("C9").Value = TC(I, 5) 'renvoie dans la cellule C9 de NO la valeur ligne I colonne 5 de TC
    Else 'sinon (si la valeur ligne I colonne 2 est vide)
        Set DEST = NO.Cells(Application.Rows.Count, 3).End(xlUp).Offset(1, 0) 'définit la cellue de destination DEST
        DEST.Value = TC(I, 4) 'renvoie dans DEST la valeur ligne I colonne 4 de TC
        DEST.Offset(1, 0).Value = TC(I, 5) 'renvoie dans la cellule en-dessous de DEST la valeur ligne I colonne 5 de TC
    End If 'fin de la condition 1
Next I 'prochaine ligne de la boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

Remarque : Ton code original était très bien écrit pour un néophyte...

Merci beaucoup ThauThème ça fonctionne impeccable

J'ai juste modifié les Dest.value TC(I, 5) par TC(I, 3) et bien sur les commentaires.

Pour finir, existe -t-il un code d'annulation concernant le bouton annuler lorsque tu lance une commande et que excel te demande d'ouvrir un fichier.

Je m'explique: Pour avoir ma feuille de données que j'ai fournie dans la pièce jointe "FichesPB.xls", j'exécute une macro qui plante lorsque je décide d'annuler pour une raison quelconque.

Idem, une fois les fiches générées et complétées je lance un outil de vérification et j'ai toujours ce souci de bouton annuler

D'avance merci beaucoup c'est vraiment super d'avoir des personnes disponibles pour aider et partager leur savoir

Bonsoir Eole, bonsoirle forum,

Quel code utilises-tu pour ta macro d'ouverture de fichier ?

Bonjour tout le monde

Voici le code que j'utilise pour ouvrir ma boite de dialogue

"Application.Dialogs(xlDialogOpen).Show " pour l'un et là c'est moi

" LeFichier = Application.GetOpenFilename("Fichier Excel (*.xls*), *.xls*")

If LeFichier <> "False" Then

Application.Workbooks.Open LeFichier

Set wbsource = ActiveWorkbook

End If "

Pour le deuxième code c'est une macro qui existait déjà fort longtemps avant que j'arrive

D'avance merci beaucoup pour ta disponibilité Thau Thème et merci à ce forum d'exister.

Bonjour Eole, bonjour le forum,

Essaie comme ça :

Sub macro1()
With Application.FileDialog(msoFileDialogOpen) 'prend en compte l'ouverture d'un fichier
    If .Show = -1 Then .Execute 'si bouton OK, exécute (ouvre le fichier sélectionné)
End With 'fin de la prise en compte de l'ouverture d'un fichier

'pour avoir un code sur le bouton "Annuler" if faut faire "If Show = 0 Then..." par exemple :
'If Show = 0 Then MsgBox "Aucun fichier n'a été sélectionné !"
'mais avec le code du dessus, au clic sur le bouton "Annuler" la boîte de dialogue se ferme tout simplement...
End Sub

Merci pour ta réponse Thau Thème mais quand j'applique le code, la boite de dialogue s'exécute deux fois et puis ferme carrément le fichier excel.

Bonjour Eole, bonjour le forum,

Plus qu'étrange ! Dans quel contexte utilise-tu le code ? Chez moi le code proposé fait :

• Soit il ouvre le ficher sélectionné (sans avoir à valider par OK)

• Soit il ferme la boîte de dialogue si je clique sur "Annuler"

Ne serait-ce pas l'ouverture du fichier qui provoquerait un plantage d'Excel ?

Re boujour thau Thème

Ben non justement quand je lance l'une ou l'autre macro dans laquelle je voulais insérer le code sans le code que tu viens de m'envoyer elles s'exécutent normalement.

C'est simplement lorsque je fais "annuler" que sa "Bogue" d'où ma demande de code pour en fait annuler le lancement de la macro par le biais du "annuler de la boite de dialogue windows "choix du fichier à ouvrir.

bonjour Eole, bonjour le forum,

Arf ! Fais un effort sinon on va pas s'en sortir... Pourrais-tu mettre soit le code complet et dire quelle est la ligne qui plante, ou mieux encore, le fichier avec le code et les indications...

Ok ok Je t'avertis c'est pas beau du tout

Pour le fichier FichesBP dans les modules 2 et 3 au démarrage il m'est demander d'aller ouvrir un fichier( là si j'annule sa "bogue")

, celui n'est pas joint, pour en extraire un onglet qui une fois décortiquer servira à remplir la base de données

Pour le fichier d'import de zone d'influence final au lancement de la macro

Avec le deuxième fichier on se sert du fichier créé par le premier afin d'extraire des données.

Pour voir le résultat final:

Fichier 1 lancer macro test, puis création

>>>>>Une fois le nouveau classeur enregistrer

Fichier 2 "lancer macro" (la si j'annule ça "bogue"

Bonsoir Eole, bonsoir le forum,

Il suffisait d'enlever les guillemets à "False"... Je ne navet (si, si, dans ce cas on peut...) jamais utiliser cette méthode mais en modifiant ton code comme ci-dessous, ça à l'air de fonctionner :

LeFichier = Application.GetOpenFilename("Fichier Excel (*.xls*), *.xls*")

If LeFichier = False Then
    Exit Sub
Else
    Application.Workbooks.Open LeFichier
    Set wbsource = ActiveWorkbook
End If

ok super merci Thau Thème sa marche sur le fichier d'import, même si le fichier va sur la feuille 1 au lieu de de la feuille 2

par contre pas du tout sur le fichier fiche PB

merci beaucoup pour ta disponibilité

Un grand merci à Thau Thème pour sa disponibilité

Un grand merci au forum d'exister

Tout fonctionne, tout marche, c'est magique alors je clos le sujet

à bientôt et encore merci

Bonjour le forum

AAAAAAhhhh désolé j'ai un problème

Quand je lance la macro et que ma base de donnée contient des lettres dans les cellules de la colonne A ça plante

je joint un fichier

merci

Bonjour Eole, bonjour le forum,

C'est la première fois que je rencontre ce genre d'erreur !?

Le code modifié :

Sub Test()
Dim D As Worksheet 'déclare la variable D (onglet Données)
Dim TC As Variant 'déclare la variable TC (Tableau de Cellules)
Dim I As Integer 'déclare la variable I (Incrément de ligne)
Dim NO As Worksheet 'déclare la variable NO (Nouvel Onglet)
Dim DEST As Range 'déclare la variable Dest (Cellule de DESTination)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set D = Sheets("Données") 'définit l'onglet D
TC = D.Range("A1").CurrentRegion 'féfinit le tableau de cellules TC
For I = 1 To UBound(TC, 1) 'boucle sur toutes les lignes I du tableau de cellules TC
   If TC(I, 2) = "Immeubles" Then Exit Sub 'si la valeur ligne I colonne 2 est egale à "Immeubles", sort de la procédure
   If TC(I, 2) <> "" Then 'condition 1 : si la valeur ligne I colonne 2 de TC n'est pas vide
       On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
       Set NO = Sheets(TC(I, 2)) 'définit l'onglet NO (génère une erreur si cet onglet n'existe pas
       If Err = 0 Then 'condition 2 : si aucune erreur n'a été générée
           Application.DisplayAlerts = False 'masque les message de l'application Excel
           NO.Delete 'supprime l'anciel onglet (facultatif mais c'est au cas ou...)
           Application.DisplayAlerts = True 'affiche les message de l'application Excel
       Else 'sinon (si une erreur a été générée
           Worksheets("PB XxXxX").Copy After:=Worksheets(ThisWorkbook.Sheets.Count) 'copie l'onglet "PB XxXxX" en dernière position
           Set NO = ActiveSheet 'définit le nouvel onglet NO
       End If 'fin de la condition 2
       On Error GoTo 0 'annule la festion des erreurs
       ActiveSheet.Name = TC(I, 1) 'définit le nom du nouvel onglet NO
       ActiveSheet.Range("F2").Value = TC(I, 1) 'renvoie dans la cellluel F2 de NO la valeur ligne I colonne 2 de TC
       ActiveSheet.Range("C7").Value = TC(I, 2) 'renvoie dans la cellule C7 de NO la valeur ligne I colonne 3 de TC
       ActiveSheet.Range("C8").Value = TC(I, 4) 'renvoie dans la cellule C8 de NO la valeur ligne I colonne 4 de TC
       ActiveSheet.Range("C9").Value = TC(I, 3) 'renvoie dans la cellule C9 de NO la valeur ligne I colonne 3 de TC
   Else 'sinon (si la valeur ligne I colonne 2 est vide)
       Set DEST = ActiveSheet.Cells(Application.Rows.Count, 3).End(xlUp).Offset(1, 0) 'définit la cellue de destination DEST
       DEST.Value = TC(I, 4) 'renvoie dans DEST la valeur ligne I colonne 4 de TC
       DEST.Offset(1, 0).Value = TC(I, 3) 'renvoie dans la cellule en-dessous de DEST la valeur ligne I colonne 3 de TC
   End If 'fin de la condition 1
Next I 'prochaine ligne de la boucle
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub

la c'est super

ça fonctionne impec

Merci beaucoup Thau Thème

Bonsoir tous le monde

Avant le lancement de la macro test y a-t-il la possibilité d'insérer un code qui efface tous les noms de formules

car des que je veux dupliquer une feuille ça me bloque excel

d'avance merci de votre disponibilité et du temps que vous m'accordez