XL 2019 Date

le___destin

le___destin

XLDnaute Occasionnel
Je veux créer une colone d'un tableau lorsque je rempli la premiere case emplie automatiquement les autre cellule jusqu'à la date du fin du moi
 
Trier par date Trier par votes
D

danielco

XLDnaute Accro
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
le___destin

le___destin

XLDnaute Occasionnel
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
le___destin

le___destin

XLDnaute Occasionnel
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
D

danielco

XLDnaute Accro
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

Discussions similaires

F
  • Résolu(e)
XL 2019 Plusieurs lignes avec mêmes donnés
2
Réponses
23
Affichages
263
DJunqueira
D
M
  • Résolu(e)
XL 2016 Alerte excel
2
Réponses
22
Affichages
729
job75
job75
H
  • Question
Microsoft 365 Calcul d'une somme de données entre 2 dates (1 ancienne et aujourd'hui)
Réponses
13
Affichages
351
Heian911
H
I
  • Résolu(e)
XL 2016 Formules Excel
Réponses
3
Affichages
182
DJunqueira
D
D
  • Question
XL 2019 Aide pour formule ou code
Réponses
2
Affichages
154
Dimitri13
D
Yuby
  • Question
XL 2016 Mise en forme conditionnelle pour une date dépassée de 3 ans par rapport à une autre date
Réponses
1
Affichages
237
JHA
J
R
  • Résolu(e)
XL 2019 Recherche valeur (Critère date et ID) et copier valeur dans tableau dans la cellule correspondante
3 4 5
Réponses
66
Affichages
2 K
Rabeto
R
T
  • Résolu(e)
XL 2016 Automatisation de la mise à jour de la date en fonction de l'état de la colonne F
Réponses
4
Affichages
169
telemarrk
T
K
  • Question
Microsoft 365 Formule excel
Réponses
7
Affichages
318
KREJ
K
X
  • Question
XL 2010 copier la valeur d'une cellule, si date du jour correspond à la date de la colonne...
Réponses
1
Affichages
267
djidji59430
djidji59430

Membres actuellement en ligne

10 membres et 82 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 196
Messages
2 086 088
Membres
103 116
dernier inscrit
kutobi87