XL 2019 Date

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
Trier par date Trier par votes
Teste (Je copie en O9:O12 les cellules fusionnées) :

VB: 
Private Sub Worksheet_Calculate()
Dim cellule As Range
  Application.EnableEvents = False
  If Application.CountIf([F12:F14], "- -") = 3 Then
    Application.DisplayAlerts = False
    [G12:G14].Copy [O9]
    [G12:G14].Validation.Delete
    [G12:G14].MergeCells = True
    Application.DisplayAlerts = True
    GoTo Fin
  End If
  If [G12:G14].MergeCells = True Then
    [G12:G14].MergeCells = False
    [O9:O12].Copy [G12]
  End If
  For Each cellule In [F12:F14]
    If cellule.Value = "- -" Then
      cellule.EntireRow.Hidden = True
    Else
      cellule.EntireRow.Hidden = False
    End If
  Next cellule
Fin:
  Application.EnableEvents = True
End Sub
 
Vote positif 0 Vote négatif
bonjour

ca march bien mais si j'applique sur le reste du tableau il ne fusionne que la premier fois
VB: 
Private Sub Worksheet_Calculate()
Dim cellule As Range
 Application.EnableEvents = False
  If Application.CountIf([F12:F14], "- -") = 3 Then
  
    Application.DisplayAlerts = False
    [G12:M14].Validation.Delete
    [G12:M14].MergeCells = True
     [V33:AB35].Copy [G12:M14]
    Application.DisplayAlerts = True
    GoTo Fin
End If
  If [G12:M14].MergeCells = True Then
    [G12:M14].MergeCells = False
    [V12:AB14].Copy [G12:M14]
  End If
 
  For Each cellule In [F12:F14]
    If cellule.Value = "- -" Then
      cellule.EntireRow.Hidden = True
    Else
      cellule.EntireRow.Hidden = False
    End If
  Next cellule
  Application.EnableEvents = True
  '--------------------------------------------------------------------------
  Dim cellul As Range
 Application.EnableEvents = False
  If Application.CountIf([F15:F17], "- -") = 3 Then
  
    Application.DisplayAlerts = False
    [G15:M17].Validation.Delete
    [G15:M17].MergeCells = True
     [V36:AB38].Copy [G15:M17]
    Application.DisplayAlerts = True
    GoTo Fin
End If
  If [G15:M17].MergeCells = True Then
    [G15:M17].MergeCells = False
    [V15:AB17].Copy [G15:M17]
  End If
 
  For Each cellul In [F15:F17]
    If cellul.Value = "- -" Then
      cellul.EntireRow.Hidden = True
    Else
      cellul.EntireRow.Hidden = False
    End If
  Next cellul
Fin:
  Application.EnableEvents = True
End Sub
 
Vote positif 0 Vote négatif
VB: 
Private Sub Worksheet_Calculate()
Dim cellule As Range
 Application.EnableEvents = False
  If Application.CountIf([F12:F14], "- -") = 3 Then
    Application.DisplayAlerts = False
    [G12:M14].Validation.Delete
    [G12:M14].MergeCells = True
     [V33:AB35].Copy [G12:M14]
    Application.DisplayAlerts = True
    GoTo Fin
End If
  If [G12:M14].MergeCells = True Then
    [G12:M14].MergeCells = False
    [V12:AB14].Copy [G12:M14]
  End If
 
  For Each cellule In [F12:F14]
    If cellule.Value = "- -" Then
      cellule.EntireRow.Hidden = True
    Else
      cellule.EntireRow.Hidden = False
    End If
  Next cellule
  Application.EnableEvents = True
  '--------------------------------------------------------------------------
 Application.EnableEvents = False
  If Application.CountIf([F15:F17], "- -") = 3 Then
  
    Application.DisplayAlerts = False
    [G15:M17].Validation.Delete
    [G15:M17].MergeCells = True
     [V36:AB38].Copy [G15:M17]
    Application.DisplayAlerts = True
    GoTo Fin
End If
  If [G15:M17].MergeCells = True Then
    [G15:M17].MergeCells = False
    [V15:AB17].Copy [G15:M17]
  End If
 
  For Each cellule In [F15:F17]
    If cellule.Value = "- -" Then
      cellule.EntireRow.Hidden = True
    Else
      cellule.EntireRow.Hidden = False
    End If
  Next cellule
   Application.EnableEvents = True
'-----------------------------------------------------------------------------------
 Application.EnableEvents = False
  If Application.CountIf([F18:F20], "- -") = 3 Then
    Application.DisplayAlerts = False
    [G18:M20].Validation.Delete
    [G18:M20].MergeCells = True
     [V33:AB35].Copy [G18:M20]
    Application.DisplayAlerts = True
    GoTo Fin
End If
  If [G18:M20].MergeCells = True Then
    [G18:M20].MergeCells = False
    [V18:AB20].Copy [G18:M20]
  End If
 
  For Each cellule In [F18:F20]
    If cellule.Value = "- -" Then
      cellule.EntireRow.Hidden = True
    Else
      cellule.EntireRow.Hidden = False
    End If
  Next cellule
  Application.EnableEvents = True
  '--------------------------------------------------------------------------
 Application.EnableEvents = False
  If Application.CountIf([F21:F23], "- -") = 3 Then
  
    Application.DisplayAlerts = False
    [G21:M23].Validation.Delete
    [G21:M23].MergeCells = True
     [V36:AB38].Copy [G21:M23]
    Application.DisplayAlerts = True
    GoTo Fin
End If
  If [G21:M23].MergeCells = True Then
    [G21:M23].MergeCells = False
    [V15:AB17].Copy [G21:M23]
  End If
 
  For Each cellule In [F21:F23]
    If cellule.Value = "- -" Then
      cellule.EntireRow.Hidden = True
    Else
      cellule.EntireRow.Hidden = False
    End If
  Next cellule
   Application.EnableEvents = True
   '------------------------------------------------------------------------------
    Application.EnableEvents = False
  If Application.CountIf([F24:F26], "- -") = 3 Then
    Application.DisplayAlerts = False
    [G24:M26].Validation.Delete
    [G24:M26].MergeCells = True
     [V33:AB35].Copy [G24:M26]
    Application.DisplayAlerts = True
    GoTo Fin
End If
  If [G24:M26].MergeCells = True Then
    [G24:M26].MergeCells = False
    [V18:AB20].Copy [G24:M26]
  End If
 
  For Each cellule In [F24:F26]
    If cellule.Value = "- -" Then
      cellule.EntireRow.Hidden = True
    Else
      cellule.EntireRow.Hidden = False
    End If
  Next cellule
  Application.EnableEvents = True
  
Fin:
  Application.EnableEvents = True
End Sub
 
Vote positif 0 Vote négatif
Essaie :

VB: 
Private Sub Worksheet_Calculate()
Dim C As Range, ResC As String, Cellule As Range
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  For Each C In Range("F12", Cells(Rows.Count, 6).End(xlUp))
    If C.Offset(, -2) <> "" And C.Offset(, -2) <> ResC Then
      ResC = C
      If Application.CountIf(C.Resize(3), "- -") = 3 Then
        Application.DisplayAlerts = False
        C.Offset(, 1).Resize(3).Copy Cells(C.Row, 15)
        C.Offset(, 1).Resize(3).Validation.Delete
        C.Offset(, 1).Resize(3).MergeCells = True
        Application.DisplayAlerts = True
        GoTo Fin
      End If
      If C.Offset(, 1).Resize(3).MergeCells = True Then
        C.Offset(, 1).Resize(3).MergeCells = False
        Cells(C.Row, 15).Resize(3).Copy C.Offset(, 1)
      End If
      For Each Cellule In C.Resize(3)
        If Cellule.Value = "- -" Then
          Cellule.EntireRow.Hidden = True
        Else
          Cellule.EntireRow.Hidden = False
        End If
      Next Cellule
    End If
  Next C
Fin:
  Application.EnableEvents = True
  Application.ScreenUpdating = True
End Sub

Daniel
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

lestoiles1
  • Résolu(e)
XL 2013 Calculer la moyenne en prennante compte des "Absent" comme 0 et s'ajuste automatiquement en ajoutant ou en supprimant les colonnes
Réponses
13
Affichages
315
lestoiles1
lestoiles1
C
  • Question Question
Microsoft 365 Déplacer une ligne sous condition
Réponses
5
Affichages
265
CB7
C
K
  • Question Question
Microsoft 365 tableau avec fonctionnement en double logique
Réponses
7
Affichages
103
KRISS2A
K
arck
  • Résolu(e)
XL 2019 macro avec fonction copié coller si rempli par la macro
Réponses
12
Affichages
430
AtTheOne
AtTheOne
F
  • Question Question
XL 2019 Demande aide formule recherche
Réponses
3
Affichages
118
Fidmo
F
Phil Du59
  • Question Question
XL 2019 Ajout d'un bouton DELETE sur mon USF
2 3
Réponses
43
Affichages
1 K
Phil Du59
Phil Du59
T
  • Résolu(e)
XL 2019 Formulaire Congés VBA
Réponses
3
Affichages
154
cathodique
cathodique
Agecanonix35400
  • Question Question
XL 2016 *** RESOLU MERCI :)*** Impression personnalisée.
2 3
Réponses
35
Affichages
518
TooFatBoy
TooFatBoy
lestoiles1
  • Résolu(e)
XL 2013 Avoir la liste dans une date précise
Réponses
4
Affichages
153
job75
job75
G
  • Question Question
Microsoft 365 Créer somme sous condition
Réponses
7
Affichages
137
gary34
G
S
  • Résolu(e)
XL 2021 Graphique TCD par date
2
Réponses
20
Affichages
516
Hecatonchire
H
K
  • Question Question
XL 2016 VBA: Selection Date renvoie copier/coller
Réponses
8
Affichages
1 K
Krome36
K
Tony44
  • Question Question
XL 2016 Transformer la mise en forme d'un tableau
2
Réponses
22
Affichages
511
Cousinhub
Cousinhub
jeff1494
  • Question Question
XL 2021 Problème à l'utilisation calendrier de Patricktoulon.
Réponses
5
Affichages
497
jeff1494
jeff1494
L
  • Question Question
XL 2021 saisie automatique d'un onglet à un autre
Réponses
2
Affichages
200
LuckyLuciano
L
Chubby
  • Résolu(e)
Microsoft 365 Modification esthétique tab
2
Réponses
18
Affichages
183
Chubby
Chubby
C
  • Question Question
Microsoft 365 format date
Réponses
3
Affichages
139
Dudu2
Dudu2
F
  • Question Question
Microsoft 365 macro-formule pour recopier une ligne automatiquement à chaque changement de nom
Réponses
5
Affichages
134
Cousinhub
Cousinhub
O
  • Question Question
XL 2013 Planification automatique des rdv d'intervention en fonction des dates disponibles
Réponses
3
Affichages
359
cathodique
cathodique
ob7523
  • Question Question
XL 2016 consommation électrique
Réponses
4
Affichages
210
ob7523
ob7523
Retour