Worksheet_change lien entre deux feuilles

Le 05/02/2021 à 15:28

Bonjour,

J'ai cette ligne de code pour activer automatiquement ma macro si la valeur change dans une cellule.

Private Sub Worksheet_change(ByVal Target As Range)
If Not Intersect(Range("b1"), Target) Is Nothing Then fusion
End Sub

Mais dans mon cas la cellule b1 n'est pas dans la feuille où il faut appliquer la fonction "fusion".

quelqu'un aurais-t-il une solution ?

Merci d'avance

Le 05/02/2021 à 15:30

Bonjour Benoit0846

Il faut envoyer un paramètre à la fonction

Call Fusion(MonParam)

Mais quel est le code de Fusion !?

@+

Le 05/02/2021 à 15:37

Bonjour BrunoM45

Voici le code de la fonction fusion

Sub fusion()
Dim nbCol As Integer, colFin As Integer, colDep As Integer, mois As Integer, col As Integer

Application.DisplayAlerts = False
Application.ScreenUpdating = False

'initialisations
colDep = 8
col = colDep
colFin = Cells(4, Columns.Count).End(xlToLeft).Column

'réinitialisation de la mise en forme et des formules
With Range(Cells(3, colDep), Cells(3, colFin))
    .UnMerge
    .Formula = Cells(3, colDep).Formula
    .HorizontalAlignment = xlLeft
End With

For j = colDep To colFin
    If mois > 0 Then
        If Month(Cells(3, j)) = mois Then
            nbCol = nbCol + 1
        Else
            'fusion
            If nbCol > 1 Then
                Range(Cells(3, col), Cells(3, col + nbCol - 1)).Merge
                Range(Cells(3, col), Cells(3, col + nbCol - 1)).HorizontalAlignment = xlCenter
            End If

            col = j
            mois = Month(Cells(3, j))
            nbCol = 1
        End If
    Else
        mois = Month(Cells(3, j))
        nbCol = 1
    End If
Next j

If nbCol > 1 Then
    'fusion
    Range(Cells(3, col), Cells(3, col + nbCol - 1)).Merge
    Range(Cells(3, col), Cells(3, col + nbCol - 1)).HorizontalAlignment = xlCenter
End If

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Le 05/02/2021 à 16:06

Re,

Pour moi, tu peux faire

Private Sub Worksheet_change(ByVal Target As Range)
  If Not Intersect(Range("b1"), Target) Is Nothing Then Call Fusion(NomFeuille)
End Sub

Avec la Sub

Sub Fusion(sNomF As String)
  Dim NbCol As Long, ColFin As Long, ColDep As Long, Mois As Integer, Col As Long
  Dim J As Long
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  ' Définir la feuille de travail
  Set Sht = Worksheets(sNomF)
  'initialisations
  ColDep = 8
  Col = ColDep
  ColFin = Sht.Cells(4, Columns.Count).End(xlToLeft).Column
  'réinitialisation de la mise en forme et des formules
  With Sht.Range(Sht.Cells(3, ColDep), Sht.Cells(3, ColFin))
    .UnMerge
    .Formula = Sht.Cells(3, ColDep).Formula
    .HorizontalAlignment = xlLeft
  End With
  ' Pour chaque colonne du début à la fin
  For J = ColDep To ColFin
    If Mois > 0 Then
      If Month(Sht.Cells(3, J)) = Mois Then
        NbCol = NbCol + 1
      Else
        'fusion
        If NbCol > 1 Then
          Sht.Range(Sht.Cells(3, Col), Sht.Cells(3, Col + NbCol - 1)).Merge
          Sht.Range(Sht.Cells(3, Col), Sht.Cells(3, Col + NbCol - 1)).HorizontalAlignment = xlCenter
        End If

        Col = J
        Mois = Month(Sht.Cells(3, J))
        NbCol = 1
      End If
    Else
      Mois = Month(Sht.Cells(3, J))
      NbCol = 1
    End If
  Next J
  ' Si Nombre de colonnes > 1
  If NbCol > 1 Then
    'fusion
    Sht.Range(Sht.Cells(3, Col), Sht.Cells(3, Col + NbCol - 1)).Merge
    Sht.Range(Sht.Cells(3, Col), Sht.Cells(3, Col + NbCol - 1)).HorizontalAlignment = xlCenter
  End If
  Application.DisplayAlerts = True
  Application.ScreenUpdating = True
End Sub

A voir

Rechercher des sujets similaires à "worksheet change lien entre deux feuilles"