Copier des donnees d'une feuille jusqu'à la derrière ligne
Résolu
Philour01
-
Philour01 -
Philour01 -
Bonjour,
Je vous soumets mon problème et vous remercie d'avance pour votre (vos) réponses d'experts. Je souhaite copier des données d'un tableau d'une feuille sur une autre feuille jusqu'à la dernière ligne. A noter une particularite avec des cellules qui comprennent des fonctions mais des resultats vides et ces cellules vides de résultats mais avec des fonctions (=si par exemple .... etc) je ne souhaite pas les copier.
Un exemple pour comprendre mon besoin :
- Tableau de 6 colonnes (composées de chiffres ou lettres) avec 15 lignes
- La derniere ligne avec cellule pleine (c'est à dire disposant d'un resultat donné par la fonction de calcul qui est dans la cellule) est la ligne 10 (mais cela change regulierement et peut être ensuite la ligne 8....)
- Attention, j'ai des fonctions dans les autres cellules (lignes 11 à 15) mais qui ne donnent pas de résultats
Mon problème est que mon code copie et colle toutes les lignes qui ont des fonctions y compris si la cellule est vide (en apparence seulement car elle dispose d'une fonction mais l'interprete comme non vide.)
Je vous soumets mon problème et vous remercie d'avance pour votre (vos) réponses d'experts. Je souhaite copier des données d'un tableau d'une feuille sur une autre feuille jusqu'à la dernière ligne. A noter une particularite avec des cellules qui comprennent des fonctions mais des resultats vides et ces cellules vides de résultats mais avec des fonctions (=si par exemple .... etc) je ne souhaite pas les copier.
Un exemple pour comprendre mon besoin :
- Tableau de 6 colonnes (composées de chiffres ou lettres) avec 15 lignes
- La derniere ligne avec cellule pleine (c'est à dire disposant d'un resultat donné par la fonction de calcul qui est dans la cellule) est la ligne 10 (mais cela change regulierement et peut être ensuite la ligne 8....)
- Attention, j'ai des fonctions dans les autres cellules (lignes 11 à 15) mais qui ne donnent pas de résultats
Mon problème est que mon code copie et colle toutes les lignes qui ont des fonctions y compris si la cellule est vide (en apparence seulement car elle dispose d'une fonction mais l'interprete comme non vide.)
A voir également:
- Copier des donnees d'une feuille jusqu'à la derrière ligne
- Partager des photos en ligne - Guide
- Comment copier une vidéo youtube - Guide
- Aller à la ligne excel - Guide
- Trier des données excel - Guide
- Mètre en ligne - Guide
76 réponses
Re,
Je t'&i déjà donné la réponse dans un post, en début de code sur le module tu verras ces lignes
Const Fichier_Réception As String = "Récap.xls"
Const Feuille_Réception As String = "Recap"
Const Fichier_Cible_1 As String = "Projet1"
Const Fichier_Cible_2 As String = "Projet2"
Const Fichier_Cible_3 As String = "Projet3"
Const Feuille_Cible As Variant = "Feuil1"
il suffit de mettre entre guillemet le nom du fichier sur lequel tu dois transférer les données
Const Fichier_Réception As String = "Récap.xls"
de même pour la feuille de réception
Const Feuille_Réception As String = "Recap"
idem pour les fichiers cibles
ensuite tu verras ce code
Sub Copie_Fichier_FerméB()
Application.DisplayAlerts = False
Call Transfert_1
Call Transfert_2
Call Transfert_3
Call DécaleDisposition
Application.CutCopyMode = False ' pour effacer le pressepapier sinon j'ai le message de trop plein quand je ferme excel
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Votre archivage est à jour," ', , "Votre archivage est à jour,"
ThisWorkbook.Save
End Sub
Call Transfert_1 concerne le fichier1 à copier
Call Transfert_2 concerne le fichier 2 à copier etc .... pour isoler un code il suffit de mettre une apostrophe devant la ligne, exemple pour isoler le code concernant le fichier Projet_3
' Call Transfert_3
A+
Mike-31
Une période d'échec est un moment rêvé pour semer les graines du savoir.
Je t'&i déjà donné la réponse dans un post, en début de code sur le module tu verras ces lignes
Const Fichier_Réception As String = "Récap.xls"
Const Feuille_Réception As String = "Recap"
Const Fichier_Cible_1 As String = "Projet1"
Const Fichier_Cible_2 As String = "Projet2"
Const Fichier_Cible_3 As String = "Projet3"
Const Feuille_Cible As Variant = "Feuil1"
il suffit de mettre entre guillemet le nom du fichier sur lequel tu dois transférer les données
Const Fichier_Réception As String = "Récap.xls"
de même pour la feuille de réception
Const Feuille_Réception As String = "Recap"
idem pour les fichiers cibles
ensuite tu verras ce code
Sub Copie_Fichier_FerméB()
Application.DisplayAlerts = False
Call Transfert_1
Call Transfert_2
Call Transfert_3
Call DécaleDisposition
Application.CutCopyMode = False ' pour effacer le pressepapier sinon j'ai le message de trop plein quand je ferme excel
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Votre archivage est à jour," ', , "Votre archivage est à jour,"
ThisWorkbook.Save
End Sub
Call Transfert_1 concerne le fichier1 à copier
Call Transfert_2 concerne le fichier 2 à copier etc .... pour isoler un code il suffit de mettre une apostrophe devant la ligne, exemple pour isoler le code concernant le fichier Projet_3
' Call Transfert_3
A+
Mike-31
Une période d'échec est un moment rêvé pour semer les graines du savoir.
Oui Mike, ok sur le nom des fichiers ... je vais le faire et en ce qui concerne les fichiers qui doivent rester ouverts comment corrige t-on le code ?
Re,
Si tes codes fonctionnent parfaitement, pour insérer ton deuxième code à la suite du premier, juste avant 'ActiveWorkbook.Save , saisi Call DécaleDisposition
Si tes codes fonctionnent parfaitement, pour insérer ton deuxième code à la suite du premier, juste avant 'ActiveWorkbook.Save , saisi Call DécaleDisposition
Cela ne fonctionnait pas à cause des variables non définies au départ.
J'ai repris ces éléments mais cela ne fonctionne toujours pas sur la deuxième macro (sub décale....). Comment identifie t-il que la ligne "Disposition spéciale" doit générer le décalage sur le bas ?
Ci-dessous ensemble du code
Option Explicit
Dim y
Dim k
Dim firstAddress
Dim Der_lig_E, Der_lig_R, Nbre_lig As Long
Const Feuille_Origine As String = "LISTE"
Const Feuille_Destination As Variant = "Edit"
Sub Transfert_Données()
Application.ScreenUpdating = False
Sheets("Edit").Select
'Dim Der_lig_E, Der_lig_R, Nbre_lig As Long
Application.ScreenUpdating = False
Sheets(Feuille_Origine).Activate
Der_lig_E = Evaluate("=MAX(IF(E:E="""",1,ROW(E:E)))") 'Variable recherche dernière ligne non vide contenant formule
Der_lig_R = Evaluate("=MAX(IF(R:R="""",1,ROW(R:R)))") 'Variable recherche dernière ligne non vide contenant formule
If Der_lig_E = Der_lig_R Then
'MsgBox "Pas de nouvelle donnée à exporter", , "Votre archivage est à jour,"
Application.ScreenUpdating = True
Sheets("Edit").Select
Range("A174").Select
Exit Sub
Else
Nbre_lig = WorksheetFunction.CountA(Range(Range("E6"), Range("E" & Der_lig_E))) ' compte ligne à copier
Sheets(Feuille_Destination).Activate
Range("E170").End(xlDown).Offset(1, 0).Resize(Nbre_lig).EntireRow.Insert '------------------- insére Nbre de ligne à copier
Sheets(Feuille_Origine).Activate
Range(Range("E" & Der_lig_E), Range("R" & Der_lig_R + 1).Offset(0, -3)).Copy '--------------- sélectionne ligne à copier
Sheets(Feuille_Destination).Activate
Range("E170").End(xlDown).Offset(1, 0).Resize(Nbre_lig).Select '----------------------------- sélectionne la première cellule vide
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlPasteFormats
Sheets(Feuille_Origine).Activate
Range(Range("E" & Der_lig_E).Offset(0, 13), Range("R" & Der_lig_R)) = "transféré"
Application.CutCopyMode = False
'MsgBox "Vos données ont été copiées", , "Votre archivage est à jour,"
Call DécaleDisposition
'ActiveWorkbook.Save '----------------------------------------------------------------------- enregistrement automatique
End If
Application.ScreenUpdating = True
Sheets("Edit").Select
Range("A174").Select
End Sub
Sub DécaleDisposition()
On Error Resume Next
Windows("ProjetDAB4").Activate
Sheets("Edit").Select
Sheets("Edit").Activate
y = "Dispositions*"
With Worksheets("ProjetDAB4").Range("E:E")
Set k = .Find(y, LookIn:=xlValues)
If Not k Is Nothing Then
firstAddress = k.Address
End If
End With
If Range(firstAddress).Row >= 216 And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(27).EntireRow.Insert
End If
End Sub
J'ai repris ces éléments mais cela ne fonctionne toujours pas sur la deuxième macro (sub décale....). Comment identifie t-il que la ligne "Disposition spéciale" doit générer le décalage sur le bas ?
Ci-dessous ensemble du code
Option Explicit
Dim y
Dim k
Dim firstAddress
Dim Der_lig_E, Der_lig_R, Nbre_lig As Long
Const Feuille_Origine As String = "LISTE"
Const Feuille_Destination As Variant = "Edit"
Sub Transfert_Données()
Application.ScreenUpdating = False
Sheets("Edit").Select
'Dim Der_lig_E, Der_lig_R, Nbre_lig As Long
Application.ScreenUpdating = False
Sheets(Feuille_Origine).Activate
Der_lig_E = Evaluate("=MAX(IF(E:E="""",1,ROW(E:E)))") 'Variable recherche dernière ligne non vide contenant formule
Der_lig_R = Evaluate("=MAX(IF(R:R="""",1,ROW(R:R)))") 'Variable recherche dernière ligne non vide contenant formule
If Der_lig_E = Der_lig_R Then
'MsgBox "Pas de nouvelle donnée à exporter", , "Votre archivage est à jour,"
Application.ScreenUpdating = True
Sheets("Edit").Select
Range("A174").Select
Exit Sub
Else
Nbre_lig = WorksheetFunction.CountA(Range(Range("E6"), Range("E" & Der_lig_E))) ' compte ligne à copier
Sheets(Feuille_Destination).Activate
Range("E170").End(xlDown).Offset(1, 0).Resize(Nbre_lig).EntireRow.Insert '------------------- insére Nbre de ligne à copier
Sheets(Feuille_Origine).Activate
Range(Range("E" & Der_lig_E), Range("R" & Der_lig_R + 1).Offset(0, -3)).Copy '--------------- sélectionne ligne à copier
Sheets(Feuille_Destination).Activate
Range("E170").End(xlDown).Offset(1, 0).Resize(Nbre_lig).Select '----------------------------- sélectionne la première cellule vide
Selection.PasteSpecial Paste:=xlPasteValues
Selection.PasteSpecial Paste:=xlPasteFormats
Sheets(Feuille_Origine).Activate
Range(Range("E" & Der_lig_E).Offset(0, 13), Range("R" & Der_lig_R)) = "transféré"
Application.CutCopyMode = False
'MsgBox "Vos données ont été copiées", , "Votre archivage est à jour,"
Call DécaleDisposition
'ActiveWorkbook.Save '----------------------------------------------------------------------- enregistrement automatique
End If
Application.ScreenUpdating = True
Sheets("Edit").Select
Range("A174").Select
End Sub
Sub DécaleDisposition()
On Error Resume Next
Windows("ProjetDAB4").Activate
Sheets("Edit").Select
Sheets("Edit").Activate
y = "Dispositions*"
With Worksheets("ProjetDAB4").Range("E:E")
Set k = .Find(y, LookIn:=xlValues)
If Not k Is Nothing Then
firstAddress = k.Address
End If
End With
If Range(firstAddress).Row >= 216 And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(27).EntireRow.Insert
End If
End Sub
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre question
Re,
que viennent faire ces lignes dans ton code
Windows("ProjetDAB4").Activate
Sheets("Edit").Select
Sheets("Edit").Activate
et d'où sort cette référence "ProjetDAB4"
With Worksheets("ProjetDAB4").Range("E:E") au départ on contrôlait la colonne B:B et la tu es en colonne E ?
Si les variables y et K ne sont pas déclarées en début de module, soit les saisir en début ou en début de code
Dim y
Dim K
Sub DécaleDisposition()
On Error Resume Next
y = "Dispositions*"
Windows("ICI LE NOM DU FICHIER.xls").Activate
Sheets("ICI NOM DE LA FEUILLE").Select
With Worksheets("ICI NOM DE LA FEUILLE").Range("E:E")
Set k = .Find(y, LookIn:=xlValues)
If Not k Is Nothing Then
firstAddress = k.Address
End If
End With
If Range(firstAddress).Row >= 216 And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(27).EntireRow.Insert
End If
End Sub
Lorsqu'on fait du VBA il faut être rigoureux sinon ça plante, on est dans la programmation, j'ai testé le code et il n'y a rien à dire, si le début de la phrase critère "Disposition" se trouve entre les lignes 216 et 235
A+
Mike-31
Une période d'échec est un moment rêvé pour semer les graines du savoir.
que viennent faire ces lignes dans ton code
Windows("ProjetDAB4").Activate
Sheets("Edit").Select
Sheets("Edit").Activate
et d'où sort cette référence "ProjetDAB4"
With Worksheets("ProjetDAB4").Range("E:E") au départ on contrôlait la colonne B:B et la tu es en colonne E ?
Si les variables y et K ne sont pas déclarées en début de module, soit les saisir en début ou en début de code
Dim y
Dim K
Sub DécaleDisposition()
On Error Resume Next
y = "Dispositions*"
Windows("ICI LE NOM DU FICHIER.xls").Activate
Sheets("ICI NOM DE LA FEUILLE").Select
With Worksheets("ICI NOM DE LA FEUILLE").Range("E:E")
Set k = .Find(y, LookIn:=xlValues)
If Not k Is Nothing Then
firstAddress = k.Address
End If
End With
If Range(firstAddress).Row >= 216 And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(27).EntireRow.Insert
End If
End Sub
Lorsqu'on fait du VBA il faut être rigoureux sinon ça plante, on est dans la programmation, j'ai testé le code et il n'y a rien à dire, si le début de la phrase critère "Disposition" se trouve entre les lignes 216 et 235
A+
Mike-31
Une période d'échec est un moment rêvé pour semer les graines du savoir.
http://cjoint.com/?CFdaGD82Q09
Re Mike,
Une version 5 avec une correction des formules de LISTE pour disposer de "" si pas de résultat au lieu de 0.
Intégration de la 2ièm fonction qui n'insère pas de saut de page et de décalage des lignes vers le bas ?
Re Mike,
Une version 5 avec une correction des formules de LISTE pour disposer de "" si pas de résultat au lieu de 0.
Intégration de la 2ièm fonction qui n'insère pas de saut de page et de décalage des lignes vers le bas ?
Re,
Je t'ai dit qu'il fallait être rigoureux en VBA
dans cette ligne le nom correspond pas et il n'y a pas l'extension si tu n'utilise pas les constante en début de code
Windows("projetDAB4").Activate
dans cette ligne tu as saisi le nom du fichier pas de la feuille
With Worksheets("projetDAB4").Range("E:E")
remplace le code par celui ci,
Sub DécaleDisposition()
On Error Resume Next
Windows("projetDAB5.xls").Activate
Sheets("Edit").Activate
y = "Dispositions*"
With Worksheets("Edit").Range("E:E")
Set k = .Find(y, LookIn:=xlValues)
If Not k Is Nothing Then
firstAddress = k.Address
End If
End With
Range(firstAddress).Select
If Range(firstAddress).Row >= 216 And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(27).EntireRow.Insert
End If
End Sub
ne t'étonne pas si je supprime des post sans intérêt afin d'écourter la discussion qui s'étend sur 5 pages
Je t'ai dit qu'il fallait être rigoureux en VBA
dans cette ligne le nom correspond pas et il n'y a pas l'extension si tu n'utilise pas les constante en début de code
Windows("projetDAB4").Activate
dans cette ligne tu as saisi le nom du fichier pas de la feuille
With Worksheets("projetDAB4").Range("E:E")
remplace le code par celui ci,
Sub DécaleDisposition()
On Error Resume Next
Windows("projetDAB5.xls").Activate
Sheets("Edit").Activate
y = "Dispositions*"
With Worksheets("Edit").Range("E:E")
Set k = .Find(y, LookIn:=xlValues)
If Not k Is Nothing Then
firstAddress = k.Address
End If
End With
Range(firstAddress).Select
If Range(firstAddress).Row >= 216 And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(27).EntireRow.Insert
End If
End Sub
ne t'étonne pas si je supprime des post sans intérêt afin d'écourter la discussion qui s'étend sur 5 pages
Merci beaucoup Mike !!
Tu as attiré mon attention sur les fichiers renommés qui ne correspondaient plus au code et effectivement il faut être particulièrement attentif.
Désolé de t'avoir fait perdre du temps et encore merci pour ta patience.
Cela fonctionne parfaitement et je vais regarder maintenant le transfert de ton troisième code.
Tu as attiré mon attention sur les fichiers renommés qui ne correspondaient plus au code et effectivement il faut être particulièrement attentif.
Désolé de t'avoir fait perdre du temps et encore merci pour ta patience.
Cela fonctionne parfaitement et je vais regarder maintenant le transfert de ton troisième code.
Re,
c'est pour cela que sur les codes initiaux j'avais créé des constantes en début de code ce qui permet d'actualiser rapidement tous les codes d'un coup, on change la valeur de la constantes sans se préoccuper des codes puisque les codes font appel à la constante
A+
Mike-31
Une période d'échec est un moment rêvé pour semer les graines du savoir.
c'est pour cela que sur les codes initiaux j'avais créé des constantes en début de code ce qui permet d'actualiser rapidement tous les codes d'un coup, on change la valeur de la constantes sans se préoccuper des codes puisque les codes font appel à la constante
A+
Mike-31
Une période d'échec est un moment rêvé pour semer les graines du savoir.
Une petite question Mike :
Les noms des projets changeants, est-il possible dans la macro d'anticiper ces changements de noms sur la partie :
exemple :
Mon fichier d'origine est projetDAB5 pour le code
Windows("projetDAB5.xls").Activate
mais si je renomme mon fichier le code ne fonctionne plus.
Les noms des projets changeants, est-il possible dans la macro d'anticiper ces changements de noms sur la partie :
exemple :
Mon fichier d'origine est projetDAB5 pour le code
Windows("projetDAB5.xls").Activate
mais si je renomme mon fichier le code ne fonctionne plus.
Re,
Non, nous sommes en programmation et encore une fois il faut être pointu, et j'en reviens aux constantes, tu changes la valeur de ta constante et si tu dois utiliser plusieurs fois le nom de fichier dans tes codes, si tu écris correctement tes codes en faisant référence à tes constantes tu n'as plus rien à faire dans tes codes.
il est toutefois possible d'anticiper, en mettant dans une cellule une formule pour afficher le nom du classeur et dans le code aller chercher ce nom, je fais des essais
Non, nous sommes en programmation et encore une fois il faut être pointu, et j'en reviens aux constantes, tu changes la valeur de ta constante et si tu dois utiliser plusieurs fois le nom de fichier dans tes codes, si tu écris correctement tes codes en faisant référence à tes constantes tu n'as plus rien à faire dans tes codes.
il est toutefois possible d'anticiper, en mettant dans une cellule une formule pour afficher le nom du classeur et dans le code aller chercher ce nom, je fais des essais
Re,
évite dans tes fichiers de déplacer tes zones d'impression exemple feuille Edit les colonnes A à C et comme je te l'ai déjà dit fusionner tes cellules
alors dans une cellule exemple en I2 tu colle cette formule qui te donnera le nom du fichier
=STXT(CELLULE("nomfichier";I1);CHERCHE("[";CELLULE("nomfichier";
A1))+1;CHERCHE("]";CELLULE("nomfichier";A1))-CHERCHE("[";
CELLULE("nomfichier";A1))-1)
ensuite dans le code tu fais référence à cette cellule,
Windows([I2].Value).Activate
mais l'idéal serait de la nommer exemple toto
Le code deviendrait
Sub DécaleDisposition()
On Error Resume Next
Windows([toto].Value).Activate
Sheets("Edit").Activate
y = "Dispositions*"
With Worksheets("Edit").Range("E:E")
Set k = .Find(y, LookIn:=xlValues)
If Not k Is Nothing Then
firstAddress = k.Address
End If
End With
Range(firstAddress).Select
If Range(firstAddress).Row >= 216 And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(27).EntireRow.Insert
End If
End Sub
évite dans tes fichiers de déplacer tes zones d'impression exemple feuille Edit les colonnes A à C et comme je te l'ai déjà dit fusionner tes cellules
alors dans une cellule exemple en I2 tu colle cette formule qui te donnera le nom du fichier
=STXT(CELLULE("nomfichier";I1);CHERCHE("[";CELLULE("nomfichier";
A1))+1;CHERCHE("]";CELLULE("nomfichier";A1))-CHERCHE("[";
CELLULE("nomfichier";A1))-1)
ensuite dans le code tu fais référence à cette cellule,
Windows([I2].Value).Activate
mais l'idéal serait de la nommer exemple toto
Le code deviendrait
Sub DécaleDisposition()
On Error Resume Next
Windows([toto].Value).Activate
Sheets("Edit").Activate
y = "Dispositions*"
With Worksheets("Edit").Range("E:E")
Set k = .Find(y, LookIn:=xlValues)
If Not k Is Nothing Then
firstAddress = k.Address
End If
End With
Range(firstAddress).Select
If Range(firstAddress).Row >= 216 And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(27).EntireRow.Insert
End If
End Sub
Super Mike, Merci, je teste dès demain car petite fatigue.
Sinon, partant d'un fichier.xlt les 2 premiers projets sont par défaut nom du fichier 1 et nom du fichier 2. Mais je trouve un intérêt à l'anticipation par la programmation et la possibilité de nommer le fichier de manière aléatoire.
Ma fonction qui annule le transfert de la nomenclature pour la modifier ne prend pas en compte actuellement le décalage des cellules à remettre à leur place.
Comment inverser le code de la 3 et 4 avant dernière ligne :
If Range(FirstAddress).Row....... Pour supprimer les lignes insérées ?
Sinon, partant d'un fichier.xlt les 2 premiers projets sont par défaut nom du fichier 1 et nom du fichier 2. Mais je trouve un intérêt à l'anticipation par la programmation et la possibilité de nommer le fichier de manière aléatoire.
Ma fonction qui annule le transfert de la nomenclature pour la modifier ne prend pas en compte actuellement le décalage des cellules à remettre à leur place.
Comment inverser le code de la 3 et 4 avant dernière ligne :
If Range(FirstAddress).Row....... Pour supprimer les lignes insérées ?
Bonjour Mike,
Je viens de tester et c'est TOP, mes fichiers renommés sont identifiés !!
Le problème qui me reste est le suivant :
Comment annuler les insertions de lignes à partir de ce code ?
J'ai aménagé ta fonction pour disposer d'un décalage avec un Resize variable selon le positionnement de la FirstAddress.
Sub DécaleDisposition()
On Error Resume Next
'Windows("projetDABV1.xls").Activate
'Windows("projetDABV2.xls").Activate
Windows([s2].Value).Activate
Sheets("Edit").Activate
y = "Dispositions*"
With Worksheets("Edit").Range("E:E")
Set k = .Find(y, LookIn:=xlValues)
If Not k Is Nothing Then
firstAddress = k.Address
End If
End With
Range(firstAddress).Select
If Range(firstAddress).Row = 215 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(39).EntireRow.Insert
End If
If Range(firstAddress).Row = 216 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(38).EntireRow.Insert
End If
If Range(firstAddress).Row = 217 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(37).EntireRow.Insert
End If
If Range(firstAddress).Row = 218 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(36).EntireRow.Insert
End If
If Range(firstAddress).Row = 219 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(35).EntireRow.Insert
End If
If Range(firstAddress).Row = 220 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(34).EntireRow.Insert
End If
If Range(firstAddress).Row = 221 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(33).EntireRow.Insert
End If
If Range(firstAddress).Row = 222 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(32).EntireRow.Insert
End If
If Range(firstAddress).Row = 223 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(31).EntireRow.Insert
End If
If Range(firstAddress).Row = 224 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(30).EntireRow.Insert
End If
If Range(firstAddress).Row = 225 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(29).EntireRow.Insert
End If
If Range(firstAddress).Row = 226 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(28).EntireRow.Insert
End If
If Range(firstAddress).Row = 227 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(27).EntireRow.Insert
End If
If Range(firstAddress).Row = 228 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(26).EntireRow.Insert
End If
If Range(firstAddress).Row = 229 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(25).EntireRow.Insert
End If
If Range(firstAddress).Row = 230 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(24).EntireRow.Insert
End If
If Range(firstAddress).Row = 231 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(23).EntireRow.Insert
End If
If Range(firstAddress).Row = 232 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(22).EntireRow.Insert
End If
If Range(firstAddress).Row = 233 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(21).EntireRow.Insert
End If
If Range(firstAddress).Row = 234 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(20).EntireRow.Insert
End If
If Range(firstAddress).Row = 235 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(19).EntireRow.Insert
End If
If Range(firstAddress).Row = 236 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(18).EntireRow.Insert
End If
If Range(firstAddress).Row = 237 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(17).EntireRow.Insert
End If
If Range(firstAddress).Row = 238 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(16).EntireRow.Insert
End If
End Sub
Je viens de tester et c'est TOP, mes fichiers renommés sont identifiés !!
Le problème qui me reste est le suivant :
Comment annuler les insertions de lignes à partir de ce code ?
J'ai aménagé ta fonction pour disposer d'un décalage avec un Resize variable selon le positionnement de la FirstAddress.
Sub DécaleDisposition()
On Error Resume Next
'Windows("projetDABV1.xls").Activate
'Windows("projetDABV2.xls").Activate
Windows([s2].Value).Activate
Sheets("Edit").Activate
y = "Dispositions*"
With Worksheets("Edit").Range("E:E")
Set k = .Find(y, LookIn:=xlValues)
If Not k Is Nothing Then
firstAddress = k.Address
End If
End With
Range(firstAddress).Select
If Range(firstAddress).Row = 215 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(39).EntireRow.Insert
End If
If Range(firstAddress).Row = 216 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(38).EntireRow.Insert
End If
If Range(firstAddress).Row = 217 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(37).EntireRow.Insert
End If
If Range(firstAddress).Row = 218 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(36).EntireRow.Insert
End If
If Range(firstAddress).Row = 219 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(35).EntireRow.Insert
End If
If Range(firstAddress).Row = 220 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(34).EntireRow.Insert
End If
If Range(firstAddress).Row = 221 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(33).EntireRow.Insert
End If
If Range(firstAddress).Row = 222 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(32).EntireRow.Insert
End If
If Range(firstAddress).Row = 223 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(31).EntireRow.Insert
End If
If Range(firstAddress).Row = 224 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(30).EntireRow.Insert
End If
If Range(firstAddress).Row = 225 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(29).EntireRow.Insert
End If
If Range(firstAddress).Row = 226 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(28).EntireRow.Insert
End If
If Range(firstAddress).Row = 227 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(27).EntireRow.Insert
End If
If Range(firstAddress).Row = 228 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(26).EntireRow.Insert
End If
If Range(firstAddress).Row = 229 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(25).EntireRow.Insert
End If
If Range(firstAddress).Row = 230 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(24).EntireRow.Insert
End If
If Range(firstAddress).Row = 231 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(23).EntireRow.Insert
End If
If Range(firstAddress).Row = 232 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(22).EntireRow.Insert
End If
If Range(firstAddress).Row = 233 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(21).EntireRow.Insert
End If
If Range(firstAddress).Row = 234 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(20).EntireRow.Insert
End If
If Range(firstAddress).Row = 235 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(19).EntireRow.Insert
End If
If Range(firstAddress).Row = 236 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(18).EntireRow.Insert
End If
If Range(firstAddress).Row = 237 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(17).EntireRow.Insert
End If
If Range(firstAddress).Row = 238 Then ' And Range(firstAddress).Row <= 235 Then
Range(firstAddress).Offset(-1, 0).Resize(16).EntireRow.Insert
End If
End Sub
Bon, j'ai trouvé quoique la suppression des lignes soit un peu longue (environ une centaine) en rajoutant la variable k qui identifie les lignes insérées désormais vides (suite à la variable i) pour les supprimer.
Cette fonction me remet en position de départ et annule toutes les insertions de lignes précédentes.
Application.ScreenUpdating = False
Worksheets("LISTE").Visible = True
Sheets("LISTE").Select
Range("R6:R55").Select
Selection.ClearContents
Range("R1").Select
Worksheets("LISTE").Visible = False
Sheets("Edit").Select
Range("A174").Select
ActiveWindow.SmallScroll Down:=-178
ActiveWindow.SmallScroll Down:=154
Sheets("Edit").Select
Dim DernierLigne As Long
For I = 1 To 55
Range("E181").Select
DernierLigne = Selection.End(xlDown).Row
If ActiveCell.Value <> 0 Then Selection.EntireRow.Delete
Next I
For k = 1 To 49
Range("E195").Select
DernierLigne = Selection.End(xlDown).Row
If ActiveCell.Value = 0 Then Selection.EntireRow.Delete
Next k
Sheets("Fiche Estimation").Select
Worksheets("LISTE").Visible = xlSheetVeryHidden
Sheets("Edit").Select
End Sub
Cette fonction me remet en position de départ et annule toutes les insertions de lignes précédentes.
Application.ScreenUpdating = False
Worksheets("LISTE").Visible = True
Sheets("LISTE").Select
Range("R6:R55").Select
Selection.ClearContents
Range("R1").Select
Worksheets("LISTE").Visible = False
Sheets("Edit").Select
Range("A174").Select
ActiveWindow.SmallScroll Down:=-178
ActiveWindow.SmallScroll Down:=154
Sheets("Edit").Select
Dim DernierLigne As Long
For I = 1 To 55
Range("E181").Select
DernierLigne = Selection.End(xlDown).Row
If ActiveCell.Value <> 0 Then Selection.EntireRow.Delete
Next I
For k = 1 To 49
Range("E195").Select
DernierLigne = Selection.End(xlDown).Row
If ActiveCell.Value = 0 Then Selection.EntireRow.Delete
Next k
Sheets("Fiche Estimation").Select
Worksheets("LISTE").Visible = xlSheetVeryHidden
Sheets("Edit").Select
End Sub
