XL 2013 Restitution automatique

[davy76]

Bonjour a tous,

je fais appel a vous car je souhaiterais faire des fiches de restitution automatique.
Je dispose d'une feuille "bilan hebdo" dans laquelle j'ai des informations.
Je souhaiterais une macro qui va renseigner la feuille "Annexe 1" en créant une nouvelle feuille pour chaque ligne du bilan hebdo.
Comme pour les fiches 1 et 2.
Dans ce fichier cela ferait 26 feuilles.
J'espère avoir été clair.

Merci pour votre aide.

 

[Fipat]

Bonsoir, voici ton fichier en retour.
Cela copie la dernière ligne saisie dans feuille annexe et crée une feuille avec le N° de la colonne A.
On vérifie également si la dernière feuille existe, par exemple sur ton fichier si la feuille 26 existe rien ne se passe. L'action se fera pour la feuille 27. Voir en Module 3.

Option Explicit

Sub annexe()
Dim ShtA As Worksheet
Dim ShtBlh As Worksheet
Dim derLig As Long
Dim f As String
Dim n As Integer
Dim trouve As Boolean
Set ShtA = Sheets("Annexe 1")
Set ShtBlh = Sheets("Bilan hebdo")
derLig = ShtBlh.Range("A" & Rows.Count).End(xlUp).Row
ShtA.[B6].Value = ShtBlh.Range("A" & derLig).Value
ShtA.[B23].Value = ShtBlh.Range("B" & derLig).Value
ShtA.[G14].Value = ShtBlh.Range("C" & derLig).Value
ShtA.[G15].Value = ShtBlh.Range("D" & derLig).Value
ShtA.[G16].Value = ShtBlh.Range("E" & derLig).Value
ShtA.[G17].Value = ShtBlh.Range("F" & derLig).Value
ShtA.[G18].Value = ShtBlh.Range("G" & derLig).Value
ShtA.[A26].Value = ShtBlh.Range("H" & derLig).Value
ShtA.[B26].Value = ShtBlh.Range("I" & derLig).Value
ShtA.[C26].Value = ShtBlh.Range("J" & derLig).Value
ShtA.[D26].Value = ShtBlh.Range("K" & derLig).Value
f = ShtA.[B6].Value
For n = 1 To Sheets.Count
 If Sheets(n).Name = f Then
  trouve = True
  Exit For
 End If
Next n
If trouve Then Exit Sub
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = f
ThisWorkbook.Worksheets("Annexe 1").Cells.Copy ThisWorkbook.Worksheets(f).Cells
Set ShtA = Nothing
Set ShtBlh = Nothing
End Sub

 

[davy76]

bonjour,

merci de votre réponse mais dans le bilan hebdo je ne rentre pas les données une par une, je fais un import global, avec votre macro je devrait faire des saisies ligne après ligne et ce n'est pas du tout ce que je cherche.

Merci

 

[Fipat]

Bonjour en faisant comme ceci alors. Cela vide le bilan hebdo mais rien n'empêche de faire une sauvegarde.
Il faut via le bouton appeler la macro dupliquer.
La création des 26 feuilles se en 2.47 secondes sur mon PC, surement un moyen plus rapide !?

Sub dupliquer()
Dim i As Integer
For i = 1 To 26
annexe
Sheets("Bilan hebdo").Select
Rows(Range("A" & Rows.Count).End(xlUp).Row).Delete
Next i
i = i + 1
End Sub

Sub annexe()
Dim ShtA As Worksheet
Dim ShtBlh As Worksheet
Dim derLig As Long
Dim f As String
Dim n As Integer
Dim trouve As Boolean
Set ShtA = Sheets("Annexe 1")
Set ShtBlh = Sheets("Bilan hebdo")
derLig = ShtBlh.Range("A" & Rows.Count).End(xlUp).Row
ShtA.[B6].Value = ShtBlh.Range("A" & derLig).Value
ShtA.[B23].Value = ShtBlh.Range("B" & derLig).Value
ShtA.[G14].Value = ShtBlh.Range("C" & derLig).Value
ShtA.[G15].Value = ShtBlh.Range("D" & derLig).Value
ShtA.[G16].Value = ShtBlh.Range("E" & derLig).Value
ShtA.[G17].Value = ShtBlh.Range("F" & derLig).Value
ShtA.[G18].Value = ShtBlh.Range("G" & derLig).Value
ShtA.[A26].Value = ShtBlh.Range("H" & derLig).Value
ShtA.[B26].Value = ShtBlh.Range("I" & derLig).Value
ShtA.[C26].Value = ShtBlh.Range("J" & derLig).Value
ShtA.[D26].Value = ShtBlh.Range("K" & derLig).Value
f = ShtA.[B6].Value
For n = 1 To Sheets.Count
 If Sheets(n).Name = f Then
  trouve = True
  Exit For
 End If
Next n
If trouve Then Exit Sub
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = f
ThisWorkbook.Worksheets("Annexe 1").Cells.Copy ThisWorkbook.Worksheets(f).Cells
Set ShtA = Nothing
Set ShtBlh = Nothing
End Sub