Discussion :

[auggytiti]

Bonjour,

Je me suis fait un code qui marche très bien pour dupliquer une feuille suivant un tableau de donnée donc chaque ligne à sa feuille.

Mon problème est là, je souhaite conserver cette macro mais qu'elle soit exécutée que sur les lignes filtrées et pas l'entièreté des lignes (qu'elle ne prenne pas en compte les lignes masquées).

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub AjoutFeuilles()
 
Dim BoEcran As Boolean, BoBarre As Boolean, BoEvent As Boolean, BoSaut As Boolean
Dim iCalcul As Integer
 
'on conserve d'abord les configuration existantes
 
BoEcran = Application.ScreenUpdating
BoBarre = Application.DisplayStatusBar
iCalcul = Application.Calculation
BoEvent = Application.EnableEvents
BoSaut = ActiveSheet.DisplayPageBreaks
 
'on force les configurations
 
Application.ScreenUpdating = False 'ne pas afficher le traitement
Application.DisplayStatusBar = False
Application.Calculation = xlManual 'commande de calcul manuel
Application.Calculation = xlAutomatic 'commande de calcul automatique
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
 
 
Dim derLi As Long
Dim i As Integer, DerniereLigne As Integer
Dim maFeuille As Worksheet
maColonne = 1 ' a ajuster
 
DerniereLigne = Range("A500").End(xlUp).Row
For i = DerniereLigne To 6 Step -1
 
    If Worksheets("ENTREPRISE").Cells(i, 2) = "" Then Worksheets("ENTREPRISE").Rows(i).Delete
Next i
 
derLi = Columns(maColonne).Find("*", , , , , xlPrevious).Row
 
 For i = 6 To derLi ' 2 si ligne de titre
   'Si la feuille existe déjà, on passe à la ligne suivante
   If FeuilleExiste(maFeuille.Cells(i, maColonne)) Then GoTo Suivant
   ' ajout d'une feuille à la fin
 
   Sheets("TA2021").Copy After:=Sheets(Sheets.Count)
   Sheets(Worksheets.Count).Name = maFeuille.Cells(i, maColonne + 1)
   Sheets(Worksheets.Count).Tab.ColorIndex = 5
   ' nom de la feuille = valeur de la cellule
   ActiveSheet.Range("B2").Value = Sheets("ENTREPRISE").Cells(i, 2)
   ActiveSheet.Range("B3").Value = Sheets("ENTREPRISE").Cells(i, 24) & " " & Sheets("ENTREPRISE").Cells(i, 25)
   ActiveSheet.Range("B4").Value = Sheets("ENTREPRISE").Cells(i, 23)
   ActiveSheet.Range("B5").Value = Sheets("ENTREPRISE").Cells(i, 3)
    ActiveSheet.Range("C13").Value = Sheets("ENTREPRISE").Cells(i, 14)
    ActiveSheet.Range("C14").Value = Sheets("ENTREPRISE").Cells(i, 16)
    ActiveSheet.Range("C15").Value = Sheets("ENTREPRISE").Cells(i, 17)
Suivant:
 
Next
'on retourne à la feuille d'origine
maFeuille.Select
Set maFeuille = Nothing
   End If
 
  Application.AskToUpdateLinks = True
  Application.Calculation = xlAutomatic 'commande de calcul automatique a mettre à la fin si au début Application.Calculation = xlManuel est présent
  Application.ScreenUpdating = True 'afficher le traitement a mettre à la fin si au début Application.ScreenUpdating = False est présent
 
  Application.ScreenUpdating = BoEcran
  Application.DisplayStatusBar = BoBarre
  Application.Calculation = iCalcul
  Application.EnableEvents = BoEvent
  ActiveSheet.DisplayPageBreaks = BoSaut
End Sub
 
Function FeuilleExiste(Nom$) As Boolean 'Ti
   On Error Resume Next
   FeuilleExiste = Sheets(Nom).Name <> ""
End Function
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = maColonne Then AjoutFeuilles
End Sub

Pouvez-vous me dire si c'est possible et de le cas me dire comment je pourrais intégré ceci (enfin si c'est bien ce code qu'il faut prendre):

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

rows_count = .ListColumns(Columns("AX").Column).DataBodyRange.SpecialCells(xlCellTypeVisible).Count

Merci

[78chris]

Bonjour

Pour cela il existe la Filtre avancé https://philippetulliez.developpez.c...dvancedfilter/
ou mieux dans nombre de cas, POwerQuery