Inserer une sauvegarde à la suite des autres + bordures VBA
Bonjour,
Je suis amené à utiliser un tableau dans lequel j'encode des données. Par le biais d'une macro, lorsque je l'execute, je sauvegarde ces données dans un autre tableau situé en dessous de celui-ci. Par conséquent, lorsque ces données sont sauvegardées, elles sont supprimées du tableau où j'encode pour pouvoir ré-encoder autre chose.
Mon soucis est le suivant: lorsque j'exécute la macro, ça sauvegarde à chaque fois à partir de la meme ligne et donc supprime les données antérieures sauvegardées. Or, j'aimerai qu'à chaque fois que j'exécute la macro, elle sauvegarde les données à la suite des autres.
Voici mon code VBA:
Sub sauvegarde()
'
' sauvegarde Macro
'
'
Application.Run "'Nouveau modèle synthèse.xlsm'!aller_a_la_ligne"
ActiveWindow.SmallScroll Down:=-33
Range("C2:C50").Select
Selection.Copy
ActiveWindow.SmallScroll Down:=12
Range("C54").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.SmallScroll Down:=-27
Range("R5").Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=21
Range("B54").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.SmallScroll Down:=-27
Range("D2:D50").Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=12
Range("D54").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.SmallScroll Down:=-33
Range("R21").Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=21
Range("E54").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.SmallScroll Down:=-18
Range("R18").Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=15
Range("G54").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.SmallScroll Down:=-21
Range("J2:J50").Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=12
Range("H54").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.SmallScroll Down:=-21
Range("H2:H50").Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=15
Range("J54").Select
Application.CutCopyMode = False
Range("J54").Select
ActiveWindow.SmallScroll Down:=-39
Range("H2:H50").Select
Application.CutCopyMode = False
Selection.Copy
ActiveWindow.SmallScroll Down:=21
Range("J54").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.SmallScroll Down:=-39
Range("B2:D51").Select
Application.CutCopyMode = False
Selection.ClearContents
Range("F2:J51").Select
Selection.ClearContents
ActiveWindow.SmallScroll Down:=-9
Range("M2:M51").Select
Selection.ClearContents
Range("O2:O51").Select
Selection.ClearContents
Range("R5:R6").Select
Selection.ClearContents
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 1
ActiveWindow.SmallScroll Down:=21
Application.Run "'Nouveau modèle synthèse.xlsm'!aller_a_la_ligne"
End SubVous trouverez ci-joint mon fichier en question, les modifications ont été faite dans la 4ème page "Bartin Claire".
Vous pouvez, pour simuler une sauvegarde, choisir 2-3 actes et ensuite appuyer sur le bouton "SAUVEGARDE" en dessous à droite du tableau.
Pour ce qui est de ma macro "aller à la ligne", elle permet d'aller à la dernière ligne pour que la suite de la sauvegarde vienne s'y coller or cela ne fonctionne. Mais lorsque que l'on execute cette macro, elle va bien à la derniere ligne.
Sub aller_a_la_ligne()
Range("C65536").End(xlUp).Offset(1, 0).Select
End SubBien à vous et merci de votre aide!
Bonjour,
Sub sauvegarde()
Dim n%, nn%
With ActiveSheet
n = .Range("C52").End(xlUp).Row - 1
If n = 1 Then Exit Sub
nn = .Range("C" & .Rows.Count).End(xlUp).Row + 1
Application.ScreenUpdating = False
.Range("C" & nn & ":D" & nn).Resize(n).Value = .Range("C2:D2").Resize(n).Value
.Range("H" & nn).Resize(n).Value = .Range("J2").Resize(n).Value
.Range("J" & nn).Resize(n).Value = .Range("H2").Resize(n).Value
.Range("B" & nn) = .Range("R5")
.Range("E" & nn) = .Range("R21")
.Range("G" & nn) = .Range("R18")
.Range("B2:D51").ClearContents
.Range("F2:J51").ClearContents
.Range("M2:M51").ClearContents
.Range("O2:O51").ClearContents
.Range("R5:R6").ClearContents
End With
End SubCe qui reste après suppression des lignes inutiles, petit changement de méthode et ajout d'un dimensionnement de plages à transférer et positionnement du transfert.
La proc. alleràlaligne est bien sûr totalement inutile.
Cordialement.
Tes 2 tableaux ne sont pas identiques.
Et on ne retrouve pas dans le 1° tous les titres de colonnes du 2°.
Pour que l'on voit bien d'où doivent venir les valeurs du 2° tableau, il faudrait que tu remplisses 2 ou 3 lignes du premier, sans colonnes vides et pareil pour le 2°, en y montrant ce que l'on doit y avoir après le clic sur sauvegarde.
Bye !
MFerrand a écrit :Bonjour,
Dans l'accumulation de code inutile on peut difficilement faire mieux ! Sub sauvegarde() Dim n%, nn% With ActiveSheet n = .Range("C52").End(xlUp).Row - 1 If n = 1 Then Exit Sub nn = .Range("C" & .Rows.Count).End(xlUp).Row + 1 Application.ScreenUpdating = False .Range("C" & nn & ":D" & nn).Resize(n).Value = .Range("C2:D2").Resize(n).Value .Range("H" & nn).Resize(n).Value = .Range("J2").Resize(n).Value .Range("J" & nn).Resize(n).Value = .Range("H2").Resize(n).Value .Range("B" & nn) = .Range("R5") .Range("E" & nn) = .Range("R21") .Range("G" & nn) = .Range("R18") .Range("B2:D51").ClearContents .Range("F2:J51").ClearContents .Range("M2:M51").ClearContents .Range("O2:O51").ClearContents .Range("R5:R6").ClearContents End With End SubCe qui reste après suppression des lignes inutiles, petit changement de méthode et ajout d'un dimensionnement de plages à transférer et positionnement du transfert.
La proc. alleràlaligne est bien sûr totalement inutile.
Cordialement.
Ca fonctionne !! Merci beaucoup !
gmb a écrit :Tes 2 tableaux ne sont pas identiques.
Et on ne retrouve pas dans le 1° tous les titres de colonnes du 2°.
Pour que l'on voit bien d'où doivent venir les valeurs du 2° tableau, il faudrait que tu remplisses 2 ou 3 lignes du premier, sans colonnes vides et pareil pour le 2°, en y montrant ce que l'on doit y avoir après le clic sur sauvegarde.
Bye !
Merci pour ta réponse, voici le fichier demandé:
Jizinho a écrit :Merci pour ta réponse, voici le fichier demandé:
Après l'excellent et oh combien patient travail de MFERRAND, (bonjour à lui !) , ma demande devient caduque.
Bye !
Bonjour,
J'ai effectué des modifications dans mon tableau, notamment l'ajout de colonnes, déplacement de colonnes, fusion des lignes 53 et 54 etc. J'ai essayé d'adapter le code que MFerrand m'a fourni mais il ne fonctionne plus. Il fonctionne mais toutes les colonnes ne sont pas complétées, seulement quelques unes ...
Voici le code que j'ai modifié : Avec celui-ci, plus rien ne s'affiche à la suite, ça remplace ce qui s'est répertorié et vu que j'ai fusionné les cellules 53 et 54, on ne voit pas la première ligne vu qu'elle se met dans la ligne 54 (qu'on ne voit plus vu qu'elle est fusionnée).
Sub sauvegarde()
Dim n%, nn%
With ActiveSheet
n = .Range("C52").End(xlUp).Row
If n = 1 Then Exit Sub: n = n - 1
nn = .Range("C" & .Rows.Count).End(xlUp).Row + 1
Application.ScreenUpdating = False
.Range("D" & nn).Resize(n).Value = .Range("C2").Resize(n).Value
.Range("E" & nn).Resize(n).Value = .Range("G2").Resize(n).Value
.Range("F" & nn).Resize(n).Value = .Range("D2").Resize(n).Value
.Range("G" & nn).Resize(n).Value = .Range("E2").Resize(n).Value
.Range("H" & nn).Resize(n).Value = .Range("K2").Resize(n).Value
.Range("I" & nn).Resize(n).Value = .Range("F2").Resize(n).Value
.Range("J" & nn).Resize(n).Value = .Range("N2").Resize(n).Value
.Range("K" & nn).Resize(n).Value = .Range("J2").Resize(n).Value
.Range("A" & nn) = .Range("T5")
.Range("B" & nn) = .Range("T3")
.Range("C" & nn) = .Range("T6")
.Range("B2:F51").ClearContents
.Range("H2:L51").ClearContents
.Range("O2:O51").ClearContents
.Range("Q2:Q51").ClearContents
.Range("T5:T6").ClearContents
End With
End SubEt voici le fichier à la feuille "Bartin Claire".
Et voici le code de MFerrand qu'il m'avait donné avant que je fasses les modifications:
Sub sauvegarde()
Dim n%, nn%
With ActiveSheet
n = .Range("C52").End(xlUp).Row - 1
If n = 1 Then Exit Sub
nn = .Range("C" & .Rows.Count).End(xlUp).Row + 1
Application.ScreenUpdating = False
.Range("C" & nn & ":D" & nn).Resize(n).Value = .Range("C2:D2").Resize(n).Value
.Range("H" & nn).Resize(n).Value = .Range("J2").Resize(n).Value
.Range("J" & nn).Resize(n).Value = .Range("H2").Resize(n).Value
.Range("B" & nn) = .Range("R5")
.Range("E" & nn) = .Range("R21")
.Range("G" & nn) = .Range("R18")
.Range("B2:D51").ClearContents
.Range("F2:J51").ClearContents
.Range("M2:M51").ClearContents
.Range("O2:O51").ClearContents
.Range("R5:R6").ClearContents
End With
End SubEst-il possible d'insérer une bordure en gras après chaque sauvegarde à la dernière ligne du dessous, pour bien les distinguer après chaque ajout sinon tout est écrit à la suite des autres et risque de jouer des tours à nos yeux?
PS: Cette macro pourra aussi être executée à l'aide d'un bouton sur d'autres feuilles? Si je fais un copier/coller sur d'autres feuilles?
Bien à vous,
Avec ce code, ça à l'air d'ajouter à la suite mais la première ligne de mon tableau principal n'est pas prise en compte vu qu'elle colle les données dans la ligne 54 qui a été fusionnée (ligne 53 et 54), j'aimerais que ma sauvegarde commence à la ligne 55 ...
Sub sauvegarde()
Dim n%, nn%
With ActiveSheet
n = .Range("D52").End(xlUp).Row
If n = 1 Then Exit Sub: n = n - 1
nn = .Range("D" & .Rows.Count).End(xlUp).Row + 1
Application.ScreenUpdating = False
.Range("D" & nn).Resize(n).Value = .Range("C2").Resize(n).Value
.Range("E" & nn).Resize(n).Value = .Range("G2").Resize(n).Value
.Range("F" & nn).Resize(n).Value = .Range("D2").Resize(n).Value
.Range("G" & nn).Resize(n).Value = .Range("E2").Resize(n).Value
.Range("H" & nn).Resize(n).Value = .Range("K2").Resize(n).Value
.Range("I" & nn).Resize(n).Value = .Range("L2").Resize(n).Value
.Range("J" & nn).Resize(n).Value = .Range("F2").Resize(n).Value
.Range("K" & nn).Resize(n).Value = .Range("N2").Resize(n).Value
.Range("L" & nn).Resize(n).Value = .Range("J2").Resize(n).Value
.Range("A" & nn) = .Range("T5")
.Range("C" & nn) = .Range("T3")
.Range("B" & nn) = .Range("T6")
.Range("B2:F51").ClearContents
.Range("H2:L51").ClearContents
.Range("O2:O51").ClearContents
.Range("Q2:Q51").ClearContents
.Range("T5:T6").ClearContents
End With
End SubPour ce qui est de la bordure en gras voici à quoi j'aimerais que ça ressemble: bordure de la ligne A à S.
Chaque date correspond à une sauvegarde ..
Bien à vous,
Voici le code qui a tout résolu:
Sub sauvegarde()
Dim n%, nn%
With ActiveSheet
n = .Range("D52").End(xlUp).Row
If n = 1 Then Exit Sub: n = n - 1
nn = .Range("D" & .Rows.Count).End(xlUp).Row + 1
If Range("L" & nn).Value <> "" Then
nn = nn + 1
End If
Application.ScreenUpdating = False
.Range("D" & nn).Resize(n).Value = .Range("C2").Resize(n).Value
.Range("E" & nn).Resize(n).Value = .Range("G2").Resize(n).Value
.Range("F" & nn).Resize(n).Value = .Range("D2").Resize(n).Value
.Range("G" & nn).Resize(n).Value = .Range("E2").Resize(n).Value
.Range("H" & nn).Resize(n).Value = .Range("K2").Resize(n).Value
.Range("I" & nn).Resize(n).Value = .Range("L2").Resize(n).Value
.Range("J" & nn).Resize(n).Value = .Range("F2").Resize(n).Value
.Range("K" & nn).Resize(n).Value = .Range("N2").Resize(n).Value
.Range("L" & nn).Resize(n).Value = .Range("J2").Resize(n).Value
.Range("A" & nn) = .Range("T5")
.Range("C" & nn) = .Range("T3")
.Range("B" & nn) = .Range("T6")
nnn = .Range("D" & .Rows.Count).End(xlUp).Row
.Range("A" & nnn & ":S" & nnn).Borders(xlEdgeBottom).Weight = xlMedium
.Range("B2:F51").ClearContents
.Range("H2:L51").ClearContents
.Range("O2:O51").ClearContents
.Range("Q2:Q51").ClearContents
.Range("T5:T6").ClearContents
End With
End SubMerci à Braters pour son aide!
Bonjour,
C'est résolu !
Juste un petit commentaire lorsque tu fais une modification qui te conduit à devoir modifier une macro.
Il faut d'abord prendre en considération la logique de la macro dans la réalisation de l'action pour pouvoir bien définir ce qui doit être modifié et ce qui doit rester.
Dans ton cas l'action principale effectuée consiste à transférer des données d'un tableau à un autre, mais sur des colonnes différentes entre les deux tableaux.
Pour le premier tableau (source), on sait à quelle ligne ça commence (2), mais on ne connait pas le nombre de lignes. On cherche donc la dernière ligne (dans une colonne adéquate), puis on retranche 1 puisqu'on commence à 2.
Si on commençait ligne 3, il faudrait alors retrancher 3, etc. On procède en 2 temps pour vérifier que la dernière ligne n'est pas celle de départ, car dans ce cas pas de données à transférer...
Pourquoi le nombre de lignes et non la dernière : parce que le nombre de ligne de la plage transférée est par définition la même pour la plage source et la plage cible. La variable recueillant le nombre de lignes permet donc de dimensionner les deux plages.
Pour le second tableau (cible), on ne connait pas la ligne de départ à utiliser, on va le déterminer dans une variable en recherchant la dernière ligne existante et prendre la suivant (+1). Ça dans presque tous les cas ainsi, sauf en cas de fusion ! car dans une plage fusionnée seule la cellule supérieure gauche peut contenir des données, les autres restant par définition vides. Fusionnant 2 lignes, si aucun transfert n'a encore eu lieu, la méthode te fera pointer sur la ligne fusionnée... Sachant que ton tableau commence à la ligne 55, il te faut un test pour le cas où la ligne trouvée serait inférieure, la ramener alors à 55.
Pour les colonnes à transférer, il suffit ensuite de t'établir une table de correspondances colonne source == colonne cible. Si elle est modifiée tu modifies.
Et à partir de ces éléments tu peux établir le schéma de transfert : plage cible = plage source, puis effacer la source... Ce schéma demeure, et lors de modifications tu sais ce qui doit bouger.
Bonne journée.
Bonjour MFerrand!
Eh bien ... Que dire de plus que Merci pour tes explications, elles me serviront
Bonne journée !
Un petit soucis (très petit):
Je souhaite recréé une autre macro (un autre bouton) par ce biais, j'inscris dans mon deuxieme tableau une ligne avec la Date - Code garde - Nom & prénom du médecin. Ensuite je fais mes manipulations dans le tableau principal et je sauvegarde (les données viendraient donc s'enregistrer à la suite de ma "nouvelle ligne" (nouvelle macro).
Le code doit du coup être le même étant donné que c'est la même manipulation ... J'ai donc fait les changements suivant mais cela ne fonctionne pas, rien ne s'affiche.
Sub sauvegarde()
Dim n%, nn%
With ActiveSheet
n = .Range("D52").End(xlUp).Row
If n = 1 Then Exit Sub: n = n - 1
nn = .Range("D" & .Rows.Count).End(xlUp).Row + 1
If Range("L" & nn).Value <> "" Then
nn = nn + 1
End If
Application.ScreenUpdating = False
.Range("A" & nn) = .Range("T5")
.Range("B" & nn) = .Range("T6")
.Range("C" & nn) = .Range("T3")
.Range("D" & nn) = .Range("T4")
End With
End SubOù est mon erreur?
Merci!
Bonjour,
Yen a pas ! ?
Tu es sûr que les données n'ont pas été effacées avant par ton autre macro ?
Si tu peux ne pas sauter de lignes comme ici, ça n'améliore pas plus la lisibilité, mais (moi au moins
Cordialement.
MFerrand a écrit :Yen a pas ! ?
Tu es sûr que les données n'ont pas été effacées avant par ton autre macro ?
Bizarre, non les données n'ont pas été effacée .. J'ai beau recommencer, la macro ne fonctionne pas et pourtant c'est exactement la même ..
MFerrand a écrit :Si tu peux ne pas sauter de lignes comme ici, ça n'améliore pas plus la lisibilité, mais (moi au moins ) ça m'oblige à scroller pour des macros qui sont encore courtes...
Je faisais un copier/coller ^^ Je supprimerai les sauts de lignes à l'avenir
Ce code fonctionne (celui que tu m'avais donné) mais même soucis qu'avait l'autre avec les lignes fusionnées.
Sub ajout_ligne()
Dim n%, nn%
With ActiveSheet
n = .Range("D52").End(xlUp).Row - 1
If n = 1 Then Exit Sub
nn = .Range("D" & .Rows.Count).End(xlUp).Row + 1
Application.ScreenUpdating = False
.Range("A" & nn) = .Range("T5")
.Range("B" & nn) = .Range("T6")
.Range("C" & nn) = .Range("T3")
.Range("D" & nn) = .Range("T4")
End With
End SubCelui-ci est issu du premier code (pas de test si absence données dans tableau source). Mais cette partie n'a pas d'effet sur cette proc. puisque tu ne prends pas les valeurs au même endroit.
Est-ce que cette macro est lancée avant ou après l'autre ?
La nouvelle macro doit être lancée avant l'autre (la sauvegarde). C'est pour ça que rien ne se supprime et donc cela devrait fonctionner.
Le code ci-dessus que j'ai adapté (que tu m'avais donné) fonctionne très bien! C'est juste que, même soucis de ma dernière requête, vu que j'ai fusionné les 2 lignes 53 et 54, on ne voit pas la première ligne vu qu'elle l'écrit dans la ligne 54 qui est déjà occupé par des cellules.
Voici le fichier pour tester:
donc dans la feuille "Bartin Claire", la date, code, nom et prénom sont indiqués. Le bouton à actionner est "Test" qui est affecté à la macro de Braters (celle où je n'ai pas supprimé les sauts de lignes et qui ne fonctionne pas) et ta macro est présente aussi en tant que "ajout_lignes_Mferrand".
Bàt,
Pas trop le temps de relire et je fatigue aujoujourd'hui.
Mais cette partie là, tu ne l'avais pas dans la 1re macro ?
Ce serait juste une question d'ordre pour faire passer avant ce que tu mettais à la fin ?
Dans ce cas, faire l'inversion dans la première, te fera gagner du temps, et plus besoin de doubler les tests.
Non parce que il y a des cellules (comme le nom) qui viennent se mettre dans des colonnes non appropriées (qui est voulu).
En exemple:
Date Code Actes Coordonnées (les titres des colonnes)
21/01..2a....Bartin...Claire (la nouvelle macro)
.............................Actes du vendredi ...
.............................Actes du jeudi ...
.............................Actes du samedi ... (la macro sauvegarde)
Voici ce à quoi j'aimerai que ça ressemble
Petite question supplémentaire ...
Est-il possible de transférer mon tableau secondaire sur une autre feuille mais que la liaison continue de se faire avec Bartin Claire? Donc j'aurai en onglet "Bartin Claire" "Bartin Claire synthèse" "Defoy Thomas "Defoy Thomas synthèse" ainsi de suite?
C'est pour faciliter à l'impression vu que je n'imprimerai que les synthèses des médecins ...
Bonjour,
Je souhaiterai non plus copier coller les données en dessous de mon tableau mais bien sur un autre tableau d'un autre onglet.
J'ai utilisé ce code qui ne fonctionne pas:
Sub sauvegarder()
Dim n%
Dim sh As Worksheet
Dim shDest As Worksheet
Set sh = ActiveSheet 'Feuille source
Set shDest = ThisWorkbook.Worksheets("Historique des gardes")
With ActiveSheet
n = .Range("D5").End(xlUp).Row
If n = 1 Then Exit Sub: n = n - 1
Application.ScreenUpdating = False 'evite le temps de latence
shDest.Range("A2") = .Range("C4") 'copie une case en particulier
shDest.Range("B2") = .Range("C5")
shDest.Range("C2") = .Range("C3")
shDest.Range("D2").Resize(n).Value = .Range("C8").Resize(n).Value 'copie les valeurs cibles = provenance
shDest.Range("E2").Resize(n).Value = .Range("G8").Resize(n).Value
shDest.Range("F2").Resize(n).Value = .Range("D8").Resize(n).Value
shDest.Range("G2").Resize(n).Value = .Range("E8").Resize(n).Value
shDest.Range("H2").Resize(n).Value = .Range("K8").Resize(n).Value
shDest.Range("I2").Resize(n).Value = .Range("L8").Resize(n).Value
shDest.Range("J2").Resize(n).Value = .Range("F8").Resize(n).Value
shDest.Range("K2").Resize(n).Value = .Range("N8").Resize(n).Value
shDest.Range("L2").Resize(n).Value = .Range("J8").Resize(n).Value
nnn = .Range("D" & .Rows.Count).End(xlUp).Row
shDest.Range("A" & nnn & ":T" & nnn).Borders(xlEdgeBottom).Weight = xlMedium 'ajoute une bordure en fin de la ligne
shDest.Range("B8:F55").ClearContents 'efface le contenu
shDest.Range("H8:L55").ClearContents
shDest.Range("O8:O51").ClearContents
shDest.Range("Q8:Q55").ClearContents
shDest.Range("T3:T5").ClearContents
End With
End SubDe plus, j'aimerais que lorsque je colle mes données, la date, le nom et le code qui sont des cellules uniques puissent se coller autant de fois qu'il y ait d'actes.
Voici le fichier:
Bien à vous et merci!