Copier le code VBA d'une feuille vers une autre feuille

Question

Bonjour à tous, j'ai besoin de copier le code VBA associé à une feuille qui me sert de référence vers une autre feuille de travail

J'ai déjà manipulé des copies de code sur des macros avec le code ci dessous mais je ne parviens pas du tout à l'adapter car il ne semble pas fonctionner pour des feuilles. Code que je tente de modifier :

dim LeCodeActuel as string
'effacement du code existant
With ThisWorkbook.VBProject.VBComponents("macrodimensionnementemf").codemodule
    .DeleteLines 1, .CountOfLines
end with
'récupération du code à copier
    With ThisWorkbook.VBProject.VBComponents("macrodimensionnementskid").codemodule
    If .CountOfLines > 0 Then
        LeCodeActuel = .Lines(1, .CountOfLines)
    End If
    End With
'copie du code récupéré vers la destination
    With ThisWorkbook.VBProject.VBComponents("macrodimensionnementemf").codemodule
    .AddFromString LeCodeActuel

merci d'avance à toute personne qui puisse me guider

saboh12617 · Accepted Answer

Ah oui c'est un gros truc…

Donc dans le module de code de ThisWorkbook, si on remplaçait votre WorksheetChange par ceci, le résultat est-il ok ? J'ai essayé de corriger les références comme je l'évoquais plus haut.

Faites un test sur une feuille après avoir supprimé votre ancienne macro dans le code feuille, et en ajouté dans ThisWorkbook celui ci-dessous.

L'intérêt est que ce code se lancerait pour toutes les feuilles donc plus besoin de le c/c partout. Et maintenance/MAJ plus facile du coup.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Source As Range)
  Dim KeyCells As Range
  Dim ligne, ligne2, ligne3, lignejaune, resultat1, resultat2, resultat12, colonne, question, enregistre, nbimage, nbactmaj, i, numpoint, j  As Integer
  Dim copier, strnumpoint As String
  Dim PhotoPresente, PhotoSupprime, trouvé As Boolean
  'KeyCells contient la zone d'alerte pour point jaunes
  Set KeyCells = Sh.Range("H1:J1000")

  If Not Application.Intersect(KeyCells, Sh.Range(Source.Address)) _
     Is Nothing Then
    ligne = Source.Row
    ligne2 = Source.Row
    ligne3 = Source.Row
    colonne = Source.Column
    If colonne = 8 Then
      'enregistrement d'un point jaune
      resultat1 = InStr(1, Sh.Range("H" & ligne).Value, "J")
      resultat2 = InStr(1, Sh.Range("H" & ligne).Value, "j")
      If Sh.Range("H" & ligne).Value = "R" Or Sh.Range("H" & ligne).Value = "r" Then resultat2 = 2
      If resultat1 = 1 Or resultat2 = 1 Then
        'procédure de copie du point jaune
        lignejaune = Worksheets("Skid").Range("B86").Value
        copier = Sh.Range("B" & ligne).Value
        Sh.Range("L" & 4 + lignejaune).Value = copier
        copier = Sh.Range("E" & ligne).Value
        Sh.Range("O" & 4 + lignejaune).Value = copier
        'Mise à jour du nombre de lignes jaune
        lignejaune = lignejaune + 1
        Worksheets("Skid").Range("B86").Value = lignejaune
        'passage de la validation en Jaune
        Sh.Range("H1").Interior.ColorIndex = 6
      End If
      If resultat2 = 2 Then
        'point rouge
        Sh.Range("H1").Interior.ColorIndex = 3
      End If
    End If
    If colonne = 9 Then
      'je regarde déjà si la case est pleine ou vide
      If Sh.Range("I" & ligne2).Value = "" Or Sh.Range("I" & ligne2).Value = Null Then
        'initialisation
        PhotoSupprime = False
        trouvé = False
        'récupération du nombre de photo enregistrées
        nbimage = Worksheets("Skid").Range("B88").Value
        'pour chaque image enregistrée je regarde si c'est cette ligne
        For i = 1 To nbimage
          If Worksheets("Skid").Range("B" & 90 + i).Value = ligne2 Then
            'la ligne est déjà comptée, j'active l'indicateur
            PhotoSupprime = True
          End If
        Next i
        If PhotoSupprime = True Then
          'je dois effacer cette photo, je commence par en enlever une
          Worksheets("Skid").Range("B88").Value = nbimage - 1
          'ensuite je balaye chaque ligne et si c'est celle-ci, soit je décale celle du dessous, soit j'efface si c'est la dernière
          For j = 1 To nbimage
            If Worksheets("Skid").Range("B" & 90 + j) = ligne2 Or trouvé = True Then
              'c'est celle ci j'efface ou je décale et j'initialise trouvé
              trouvé = True
              If j = nbimage Then
                'c'est la dernière alors j'efface
                Worksheets("Skid").Range("B" & 90 + j) = ""
              ElseIf j < nbimage Then
                'ce n 'est pas la dernière alors je décale
                Worksheets("Skid").Range("B" & 90 + j) = Worksheets("Skid").Range("B" & 90 + j + 1)
              End If
            End If
          Next j
        End If
      End If
      'récupération du nombre de photo déjà présentes
      ' initialisation des variables
      PhotoPresente = False
      'enregistrement d'une photo
      resultat12 = InStr(1, Sh.Range("I" & ligne2).Value, "")
      If resultat12 = 1 Then
        'test si la photo existe déjà
        nbimage = Worksheets("Skid").Range("B88").Value
        For i = 1 To nbimage
          If Worksheets("Skid").Range("B" & 90 + i).Value = ligne2 Then
            'la ligne existe déjà
            PhotoPresente = True
          End If
        Next i
        If PhotoPresente = False Then
          'c'est une nouvelle photo j'enregistre
          nbimage = Worksheets("Skid").Range("B88").Value
          nbimage = nbimage + 1
          Worksheets("Skid").Range("B88").Value = nbimage
          'enregistrement du N° de ligne
          Worksheets("Skid").Range("B" & 90 + nbimage).Value = ligne2
        End If
      End If
    End If
    If colonne = 10 Then
      'j'ai des actions à mettre à jour
      'ecriture du nombre d'action à mettre à jour et de leur lignes
      resultat1 = InStr(1, Sh.Range("J" & ligne3).Value, "X")
      resultat2 = InStr(1, Sh.Range("J" & ligne3).Value, "x")
      If resultat1 = 1 Or resultat2 = 1 Then
        nbactmaj = Worksheets("Skid").Range("C92").Value
        nbactmaj = nbactmaj + 1
        'enregistrement du N° de ligne
        Worksheets("Skid").Range("D" & 91 + nbactmaj).Value = ligne3
        'enregistrement du nombre de ligne mise à jour
        Worksheets("Skid").Range("C92").Value = nbactmaj
        'détermination si c'est un point jaune
        If ActiveSheet.Range("H" & ligne3).Value = "j" Or ActiveSheet.Range("H" & ligne3).Value = "J" Then
          'détermination du N° de point jaune
          NumeroPointJaune.Show 1
          Do While NumeroPointJaune.Visible = True
            DoEvents
          Loop
          numpoint = Worksheets("Skid").Range("G97").Value
          'effacement du point jaune dans le tableau de synthèse
          ActiveSheet.Range("L" & 3 + numpoint).Value = ""
          ActiveSheet.Range("O" & 3 + numpoint).Value = ""
        End If
        'mise en couleur du fond de cellule
        ActiveSheet.Range("A" & ligne3 & ":" & "J" & ligne3).Select
        Selection.Interior.Color = RGB(226, 239, 218)
      End If
    End If
  End If
End Sub

saboh12617 · Accepted Answer

Ok, bon courage.Je dois avouer que le projet est très lourd et c'est dur pour moi d'en saisir tout le fonctionnement.

Une idée, au début du sub que je vous ai envoyé, ajoutez Application.EnableEvents = False et à la fin avant la dernière ligne Application.EnableEvents = True. Ca évitera que les autres macros interfèrent.

Ensuite je viens de voir que vos déclarations ne font pas ce que vous voulez. Quand vous écrivez Dim a, b As Integer, vous avez a qui est Variant et b qui est Integer. Le As ne s'applique qu'au dernier élément.Donc la déclaration correcte est la suivante :

  Dim KeyCells As Range
  Dim ligne As Integer, ligne2 As Integer, ligne3 As Integer, lignejaune As Integer, resultat1 As Integer, resultat2 As Integer, resultat12 As Integer, colonne As Integer, question As Integer, enregistre As Integer, nbimage As Integer, nbactmaj As Integer, i As Integer, numpoint As Integer, j As Integer
  Dim copier As String, strnumpoint As String
  Dim PhotoPresente As Boolean, PhotoSupprime As Boolean, trouvé As Boolean

saboh12617 · Answer

Alors c'est normal que ça ne fonctionne pas car votre code se réfère à un module VBA, pas un module de feuille. Mais avant d'aller plus loin on devrait se poser quelques questions : Pourquoi copiez-vous le code via du code ? Ne pouvez-vous pas le faire manuellement ? La question qui suit est : si vous devez l'automatiser c'est probablement qu'il y a beaucoup de feuilles, dans ce cas pourquoi ne pas réfléchir à déplacer ce code dans un module VBA et/ou dans l'objet workbook ? Si vous pouviez préciser l'objectif du code copié, et partager un fichier d'exemple, je pense qu'on pourrait avancer plus productivement...

saboh12617 · Answer

Merci pour vos explications.

Alors comme je le disais, il existe pour le workbook (classeur) l'évènement Workbook.SheetChange event (Excel) | Microsoft Learn qui correspond à Worksheet.Change mais pour l'ensemble du classeur. Ca permettrai de garder votre code quasiment à l'identique, il faudrait juste changer les références de cellules de la feuille active vers le paramètre Sh (avec un With par exemple).

Mais bon un classeur joint serait utile car je n'ai pas bien compris cette histoire de CR.

saboh12617 · Answer

Je vous en prie, content d'aider. Si vous avez d'autres questions n'hésitez pas. Si le problème est résolu, pensez à cloturer le fil. Bonne journée...