Réaliser un encadré double

Le 08/07/2019 à 10:05

Bonjour,

Toujours pour réaliser mes jeux, et afin d'enjoliver mes plages de cellules pour aboutir à de magnifiques présentations tellement belles que vous devriez mettre vos lunettes de soleil avant d'aller voir cet exemple : https://forum.excel-pratique.com/viewtopic.php?f=9&t=119939, j'aimerais disposer d'une macro permettant :

1. sélection plage de cellules

2. bordure noire medium

3. sélection des cellules entourant la plage

4. coloration de ces cellules avec choix de couleur)

5. écriture d'apostrophes dans chaque coin coloré

6. positionnement du curseur dans la cellule colorée en haut à gauche

ça donnerait ceci :

plage de départ à traiter .............. plage après traitement (apostrophes invisibles ici)

cdrj1e10

En ce qui concerne les points 1 et 5, James007 m'a grandement aidé en me fournissant cette macro, que j'ai adapté en fin de topic : https://forum.excel-pratique.com/viewtopic.php?f=2&t=126875

Ci-joint le fichier "cadrages"

avec une macro enregistrée relativement "kdrj", qu'il faudrait adapter à chaque cas de plage (les plages pouvant être de tailles et d'emplacements forts différents), et là, je ne sais pas faire, d'où ma demande d'aide.

Sub kdrj()
'
' kdrj Macro
' Macro enregistrée le 08/07/2019 par utilisateur
'

'
    ActiveCell.Offset(-1, -1).Range("A1:F4").Select
    With Selection.Interior
        .ColorIndex = 6
        .Pattern = xlSolid
    End With
    ActiveCell.Offset(1, 1).Range("A1:D2").Select
    Selection.Interior.ColorIndex = xlNone
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    ActiveCell.Offset(-1, -1).Range("A1").Select
End Sub

On y voit notamment que je n'ai pas réussi à intégrer la macro déjà créée par James007.

Ah, vivent les vacances !

13cadrages.xls (15.00 Ko)
Le 09/07/2019 à 11:42

Bonjour,

Tu as intérêt à n'avoir qu'une seule macro pour tes différentes opérations ...

Sub AposCopie5()
Dim rngS As Range
Dim rngD As Range

 On Error Resume Next
    Set rngS = Application.InputBox( _
      Title:="Plage Source", _
      Prompt:="Merci de saisir la plage Source", _
      Type:=8)

    Set rngD = Application.InputBox( _
      Title:="Plage Destination", _
      Prompt:="Merci de saisir la cellule Destination", _
      Type:=8)
  On Error GoTo 0

rngS.Copy Destination:=rngD

rngD(1, 1).Offset(-1, -1).Value = "'"
rngD(1, 0).Offset(-1, rngS.Columns.Count + 1).Value = "'"
rngD(0, 1).Offset(rngS.Rows.Count + 1, -1).Value = "'"
rngD(0, 0).Offset(rngS.Rows.Count + 1, rngS.Columns.Count + 1).Value = "'"

    With Sheet2
        .Range(rngD(1, 1).Offset(-1, -1).Address(0, 0) & ":" & rngD(1, 0).Offset(-1, rngS.Columns.Count + 1).Address(0, 0)).Interior.Color = vbYellow
        .Range(rngD(1, 1).Offset(-1, -1).Address(0, 0) & ":" & rngD(0, 1).Offset(rngS.Rows.Count + 1, -1).Address(0, 0)).Interior.Color = vbYellow
        .Range(rngD(0, 1).Offset(rngS.Rows.Count + 1, -1).Address(0, 0) & ":" & rngD(0, 0).Offset(rngS.Rows.Count + 1, rngS.Columns.Count + 1).Address(0, 0)).Interior.Color = vbYellow
        .Range(rngD(1, 0).Offset(-1, rngS.Columns.Count + 1).Address(0, 0) & ":" & rngD(0, 0).Offset(rngS.Rows.Count + 1, rngS.Columns.Count + 1).Address(0, 0)).Interior.Color = vbYellow
    End With

Application.Goto rngD(1, 1).Offset(-1, -1)

End Sub

En espèrant que cela t'aide

Le 09/07/2019 à 14:07

Hello James !

Merci encore pour ton investissement.

Je n'ai pas encore réussi à faire fonctionner correctement ta nouvelle macro, sur laquelle tu viens de te pencher si gentiment.

Il y a un premier bug, la macro surligne en jaune cette ligne :

.Range(rngD(1, 1).Offset(-1, -1).Address(0, 0) & ":" & rngD(1, 0).Offset(-1, rngS.Columns.Count + 1).Address(0, 0)).Interior.Color = vbYellow

A quoi cela pourrait-il correspondre, et comment l'arranger ?

(PS, je reviens en fin d'après-m.)

Le 09/07/2019 à 14:11

Hello,

Je viens de re-tester la macro sur ton fichier ...

Pas de bug ...

Le 09/07/2019 à 18:17

???

Erreur d'exécution '424'

Objet requis.

Détaillons le procédé:

1. Je lance la macro AposCopie5

2. Je saisis la plage E13-H14

3. Je choisis la cellule E13 (ou D12, peu importe)

4. Je lis le message d'erreur

9. Je suis perplexe

8. J'essuie père plexe

6. Je régresse

5. J'appelle à l'aide

007 !

Le 09/07/2019 à 18:27

bonjour,

vérifie si ce nom est correct pour ton fichier

With Sheet2
Le 09/07/2019 à 19:09

Salut h2so4, merci pour ton intervention.

With Sheet2 est bien dans le fichier macro Aposcopie5, était-ce la question?

La différence est que With n'est pas écrit en bleu.

Je rappelle que je fonctionne sur Excel 2003, ça a peut-être son importance.

Ah non, je viens de lancer Excel 2007, j'obtiens le même message d'erreur.

Que se passe-t-il ? Quelle catastrophe ai-je encore déclenchée ?

Tiens, je vais faire un petit Triogical, genre Gardens of Babylon (mapset 3, map 98)

Le 09/07/2019 à 19:20

Re,

Ci-joint ton propre fichier test ...en Version 2 avec ta macro

Si tu as des difficultés ... au lieu de dire : "çà ne marche pas ..."

Plus efficace ... joins ton ' nouveau ' fichier test ...

11aposeapostrophe-v2.xlsm (24.09 Ko)
Le 09/07/2019 à 19:49

Excellent, ça marche pour ce fichier !

Mon problème va consister à l'adapter pour n'importe quel autre fichier. Je vais voir comment je peux faire, car pour l'instant seul le fichier que tu as joint fonctionne sans bug.

On progresse quand même à pas de géant ! Bravo James. 2152024857

A demain !

Le 09/07/2019 à 19:56

Re,

Au risque de me répéter ...

Si tu as des difficultés ... Au lieu de dire : "çà ne marche pas ..."

Plus efficace ... joins ton ' nouveau ' fichier test ...

Le 10/07/2019 à 10:39

Désolé, je ne pense pas à tout. Mais heureusement, je ne pense pas à rien non plus.

Voici donc 2 fichiers Test3 et Test4, le premier en allant chercher avec Alt-F8 la macro

Sub AposCopie5()
'
' AposCopie5 Macro
' Macro enregistrée le 09/07/2019 par utilisateur
'

Dim rngS As Range
Dim rngD As Range

 On Error Resume Next
    Set rngS = Application.InputBox( _
      Title:="Plage Source", _
      Prompt:="Merci de saisir la plage Source", _
      Type:=8)

    Set rngD = Application.InputBox( _
      Title:="Plage Destination", _
      Prompt:="Merci de saisir la cellule Destination", _
      Type:=8)
  On Error GoTo 0

rngS.Copy Destination:=rngD

rngD(1, 1).Offset(-1, -1).Value = "'"
rngD(1, 0).Offset(-1, rngS.Columns.Count + 1).Value = "'"
rngD(0, 1).Offset(rngS.Rows.Count + 1, -1).Value = "'"
rngD(0, 0).Offset(rngS.Rows.Count + 1, rngS.Columns.Count + 1).Value = "'"

    With Sheet2
        .Range(rngD(1, 1).Offset(-1, -1).Address(0, 0) & ":" & rngD(1, 0).Offset(-1, rngS.Columns.Count + 1).Address(0, 0)).Interior.Color = vbYellow
        .Range(rngD(1, 1).Offset(-1, -1).Address(0, 0) & ":" & rngD(0, 1).Offset(rngS.Rows.Count + 1, -1).Address(0, 0)).Interior.Color = vbYellow
        .Range(rngD(0, 1).Offset(rngS.Rows.Count + 1, -1).Address(0, 0) & ":" & rngD(0, 0).Offset(rngS.Rows.Count + 1, rngS.Columns.Count + 1).Address(0, 0)).Interior.Color = vbYellow
        .Range(rngD(1, 0).Offset(-1, rngS.Columns.Count + 1).Address(0, 0) & ":" & rngD(0, 0).Offset(rngS.Rows.Count + 1, rngS.Columns.Count + 1).Address(0, 0)).Interior.Color = vbYellow
    End With

Application.Goto rngD(1, 1).Offset(-1, -1)

End Sub

Le second après avoir créé un bouton affecté de la même macro.

Mêmes résultats : ça ne marche pas (ah non, faut pas le dire) ça marche très bien, mais avec un bug. Oh, punaise ! Mais caisse pastille donc ?

Où est le petit grain de poussière à nettoyer ?

10test3-aposcopie5.xls (17.50 Ko)
9test4-aposcopie5-bouton.xls (18.00 Ko)
Le 10/07/2019 à 12:58

Bonjour,

Je pense que tu dois être tout de même très ' tête-en-l'air ' ...

Tu postes deux fichiers tests ... et dans aucun de tes deux fichiers tests ... il n'y a la moindre macro ...

Ci-joint la Version 5 de ton Test 5 ...

8test5-aposcopie5-bouton.xlsm (17.37 Ko)
Le 10/07/2019 à 18:07

J'enregistre mes macros dans un classeur PERSO.

Comment faire pour associer une macro à un fichier ?

J'ai du mal à comprendre ceci : https://forum.excel-pratique.com/viewtopic.php?t=19539

EDIT

Désolé, ça y est.

8test5-aposcopie5bis-bouton.zip (9.76 Ko)
Le 10/07/2019 à 18:35
Patapin85 a écrit :

J'enregistre mes macros dans un classeur PERSO.

Comment faire pour associer une macro à un fichier ?

J'ai du mal à comprendre ceci : https://forum.excel-pratique.com/viewtopic.php?t=19539

EDIT

Désolé, ça y est.

Toujours plus simple de régler un problème ... après l'autre ...

1. As-tu testé la version 5 ... qui corrige ton test 4 ...?

2. As-tu lu tes messages privés ?

Le 11/07/2019 à 10:21

Hello !

La fin est proche

Merci pour le message privé (ça marche !)

Avant mon dernier post, je n'avais pas vu ta version Test5, d'où l'envoi de mon propre test5Aposcopie5BIS.

J'ai testé ta version 5 corrigeant la mienne, et je suis presque arrivé pas à transposer la macro dans mon fichier réel !

Tu as bien travaillé, tes corrections font que la macro telle qu'elle est est parfaitement opérationnelle, c'est-à-dire sans bug et sans reprogche!

Il ne me manque plus qu'à intégrer une bordure noire afin de passer de ceci :

apos610

à cela

apos6 10

Ci-joint le fichier cadrages2 avec la macro aposcopie7, qui est en fait exactement la même que ta dernière version, je n'ai osé toucher à rien. Sinon j'aurais tout cassé, j'ai deux mains gauches (surtout la droite).

7cadrages2.zip (9.14 Ko)
Le 11/07/2019 à 13:46

Re,

Ci-joint ta dernière version ...

8test6-aposcopie6.xlsm (18.97 Ko)
Le 11/07/2019 à 15:07

Génial, James !

Tu as réussi à me faire réussir à utiliser ta macro.

Après bien des essais, ta dernière version est excellente. Et en plus... elle marche !

Le 11/07/2019 à 15:36

Merci pour tes remerciements

Rechercher des sujets similaires à "realiser encadre double"