modification du code ajout feuille pour impression pages multiples
bonjour a vous tous
je voudrais modifier le code que voici afin de pouvoir avoir feuil2 et non feuille(2) comme actuellement afin de voir les 2 dans l'aperçu et pouvoir organiser la zone d'impression mais il peut y avoir jusque 6 feuilles nommées
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
| Function LigneSuivante() As String
'Ligne début et fin d'écriture sur la feuille Facturation
Const LigneMinFact1 As Byte = 19, LigneMaxFact1 As Byte = 51
'Ligne début et fin d'écriture sur les feuilles Facturation suivante
Const LigneMinFactS As Byte = 7, LigneMaxFactS As Byte = 51
Dim nouvellefeuille As Worksheet
Dim Cellule As Range
Dim boucle As Byte
Dim test As String, nomFeuille As String
LigneSuivante = ""
'chercher si une ligne est vide dans la feuille facturation
With Worksheets("facturation")
For Each Cellule In .Range(.Cells(LigneMinFact1, 3), .Cells(LigneMaxFact1, 3))
If Cellule = "" Then
LigneSuivante = "facturation," & Cellule.Row
Exit For
End If
Next
If Not Cellule Is Nothing Then _
If Cellule.Row > LigneMinFact1 And Cellule.Row < LigneMaxFact1 Then .Rows(Cellule.Row).Insert Shift:=xlDown
'si une ligne vide est trouvé -> sortir
If LigneSuivante <> "" Then Exit Function
End With
For boucle = 2 To 255
'Vérifier si une autre feuille facturation existe
nomFeuille = "facturation(" & boucle & ")"
On Error Resume Next
test = Sheets(nomFeuille).Name
On Error GoTo 0: Err.Clear
If test <> nomFeuille Then 'la feuille n'existe pas il faut la créer
Set nouvellefeuille = Worksheets.Add(after:=Worksheets(Worksheets.Count))
nouvellefeuille.Name = nomFeuille
'Collage des ligne à reporter
'en-tête
Sheets("facturation").Rows(LigneMinFact1 - 3 & ":" & LigneMinFact1 - 1).Copy
nouvellefeuille.Rows(LigneMinFactS - 3 & ":" & LigneMinFactS - 1).PasteSpecial Paste:=xlPasteValues
nouvellefeuille.Rows(LigneMinFactS - 3 & ":" & LigneMinFactS - 1).PasteSpecial Paste:=xlPasteFormats
'Format tableau des lignes
Sheets("facturation").Rows(LigneMinFact1).Copy
nouvellefeuille.Rows(LigneMinFactS).PasteSpecial Paste:=xlPasteFormats
'les deux dernieres ligne
Sheets("facturation").Rows(LigneMaxFact1 & ":" & LigneMaxFact1 + 1).Copy
nouvellefeuille.Rows(LigneMinFactS + 1 & ":" & LigneMinFactS + 2).PasteSpecial Paste:=xlPasteFormats
'Largeur des colonnes
Sheets("facturation").Cells.Copy
nouvellefeuille.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths
'Réécriture des formules
With nouvellefeuille
.Range("L" & LigneMinFactS + 2).FormulaLocal = "=SOMME(L" & LigneMinFactS & ":L" & LigneMinFactS + 1 & ")"
.Range("O" & LigneMinFactS + 2).FormulaLocal = "=SOMME(O" & LigneMinFactS & ":O" & LigneMinFactS + 1 & ")"
.Range("P" & LigneMinFactS + 2).FormulaLocal = "=SOMME(P" & LigneMinFactS & ":P" & LigneMinFactS + 1 & ")"
End With
LigneSuivante = nomFeuille & "," & LigneMinFactS
'comme la feuille vient d'être créé on sait ou ecrire donc quitter la fonction
Exit Function
Else
'chercher si une ligne est vide dans la feuille facturation(x)
With Worksheets(nomFeuille)
For Each Cellule In .Range(.Cells(LigneMinFactS, 3), .Cells(LigneMaxFactS, 3))
If Cellule = "" Then
LigneSuivante = nomFeuille & "," & Cellule.Row
Exit For
End If
Next
If Not Cellule Is Nothing Then _
If Cellule.Row > LigneMinFactS And Cellule.Row < LigneMaxFactS Then .Rows(Cellule.Row).Insert Shift:=xlDown
'si une ligne vide est trouvé -> sortir
If LigneSuivante <> "" Then Exit Function
End With
End If
Next
End Function |
si vous avez des suggestions afin de modifier ce code ou d'y ajouté un code
cordialement
Pascal
