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
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
Fin:
Next C
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
alors que je veux quel soit F12:M15
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, 7).Copy Cells(C.Row, 22)
C.Offset(, 1).Resize(3, 7).Validation.Delete
C.Offset(, 1).Resize(3, 7).MergeCells = True
Application.DisplayAlerts = True
GoTo Fin
End If
If C.Offset(, 1).Resize(3).MergeCells = True Then
C.Offset(, 1).Resize(3, 7).MergeCells = False
Cells(C.Row, 22).Resize(3, 7).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
Fin:
Next C
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
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
Debug.Print C.Address(0, 0)
ResC = C
If Application.CountIf(C.Resize(3), "- -") = 3 Then
If C.Offset(, 1).Resize(3).MergeCells = False Then
Application.DisplayAlerts = False
C.Offset(, 1).Resize(3, 7).Copy Cells(C.Row, 22)
C.Offset(, 1).Resize(3, 7).Validation.Delete
C.Offset(, 1).Resize(3, 7).MergeCells = True
Application.DisplayAlerts = True
End If
GoTo Fin
End If
If C.Offset(, 1).Resize(3).MergeCells = True Then
C.Offset(, 1).Resize(3, 7).MergeCells = False
Cells(C.Row, 22).Resize(3, 7).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
Fin:
Next C
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub