Bonjour,
J'ai une macro qui plante parfois sans que je parvienne à trouver la cause (mes connaissances en VBA sont rudimentaires).
j'ai mis la macro ci après juste pour vous donner une idée des compétences requises mais sans le fichier pour essayer cela n'a pas vraiment d'intéret.
Le fichier pesant 5 mo, vous pouvez le télécharger à cette adresse :
Free - Envoyez vos documents
Le bug intervient lors de l'éxécution de la macro du boution "trier" sur la feuille "marc".
Pourtant, ce n'est pas un problème de données car en copiant les données qui sont triées (de la cellule A2 à E25) sur la feuille "réserve" la macro fonctionne.
C'est comme si des données invisibles étaient présentes plus bas dans la feuille. Mais même en effaçant le contenu des cellules situées en dessous des cellules et jusqu'à la ligne 1000 (comme spécifié dans la macro) cela bug toujours....
Votre aide serait la bienvenue et bein sur je reste à disposition pour expliquer le focntionnement de la macro.
Cordialement
Emmanuel
Sub trier()
' deprotéger la feuille
ActiveSheet.Unprotect
'effacer le contenu des colonnes G et H
Range("G2:H1000").Select
Selection.ClearContents
'trier les lignes
Range("A2:E1000").Select
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("D2") _
, Order2:=xlAscending, Key3:=Range("C2"), Order3:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'effacer les #
Dim Plage As Range
Dim Cell As Range
Set Plage = Range("C2:C" & Range("C1000").End(xlUp).Row)
For Each Cell In Plage
If Cell.Value = "#" Then
Cell.Clear
End If
Next Cell
Dim c As Range
Dim firstAddress As String
Dim ChaineSelection As String
Dim I As Double
Application.ScreenUpdating = False
'efface les lignes contenant #
ChaineSelection = ""
With Range("C2", Range("C1000").End(xlUp).Address)
Set c = .Find("#", After:=Range("C2"))
If Not c Is Nothing Then
firstAddress = c.Address
Do
ChaineSelection = ChaineSelection & Range(c.Offset(0, -2), c.Offset(0, 2)).Address & ","
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
ChaineSelection = Mid(ChaineSelection, 1, Len(ChaineSelection) - 1)
Range(ChaineSelection).Delete shift:=xlUp
End If
End With
'insère les lignes avec des # autant de fois qu'il y a d'heures spécifiées
For I = Range("E1000").End(xlUp).Row To 2 Step -1
If Range("E1").Offset(I - 1, 0) > 1 Then
Range(Range("A1").Offset(I, 0), Range("E1").Offset(Range("E1").Offset(I - 1, 0) + I - 2, 0)).Insert shift:=xlDown
Range(Range("C1").Offset(I, 0), Range("C1").Offset(Range("E1").Offset(I - 1, 0) + I - 2, 0)) = "#"
End If
Next
'inscrie les jouurs de la semaine autant de fois qu'ils comportent d'heure
Dim vLigne As Double
vLigne = 1
For I = 1 To Range("J1000").End(xlUp).Row - 1
If Range("k1").Offset(I, 0) > 0 Then
Range(Range("G1").Offset(vLigne, 0), Range("G1").Offset(vLigne + Range("k1").Offset(I, 0) - 1, 0)) = Range("J1").Offset(I, 0)
vLigne = vLigne + Range("k1").Offset(I, 0)
End If
Next
' recopier la formule de H2 à H1000
Range("H2").Select
ActiveCell.FormulaR1C1 = "=IF(ISBLANK(RC[-4]),"""",RC[-4]-(RC[-1]+2))"
Range("H2:H1000").Select
Selection.FillDown
'enlever protection cellule
Range("A2:I1000").Select
Selection.Locked = False
'se positionner en B2
Range("B2").Select
Application.ScreenUpdating = True
End Sub
J'ai une macro qui plante parfois sans que je parvienne à trouver la cause (mes connaissances en VBA sont rudimentaires).
j'ai mis la macro ci après juste pour vous donner une idée des compétences requises mais sans le fichier pour essayer cela n'a pas vraiment d'intéret.
Le fichier pesant 5 mo, vous pouvez le télécharger à cette adresse :
Free - Envoyez vos documents
Le bug intervient lors de l'éxécution de la macro du boution "trier" sur la feuille "marc".
Pourtant, ce n'est pas un problème de données car en copiant les données qui sont triées (de la cellule A2 à E25) sur la feuille "réserve" la macro fonctionne.
C'est comme si des données invisibles étaient présentes plus bas dans la feuille. Mais même en effaçant le contenu des cellules situées en dessous des cellules et jusqu'à la ligne 1000 (comme spécifié dans la macro) cela bug toujours....
Votre aide serait la bienvenue et bein sur je reste à disposition pour expliquer le focntionnement de la macro.
Cordialement
Emmanuel
Sub trier()
' deprotéger la feuille
ActiveSheet.Unprotect
'effacer le contenu des colonnes G et H
Range("G2:H1000").Select
Selection.ClearContents
'trier les lignes
Range("A2:E1000").Select
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("D2") _
, Order2:=xlAscending, Key3:=Range("C2"), Order3:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'effacer les #
Dim Plage As Range
Dim Cell As Range
Set Plage = Range("C2:C" & Range("C1000").End(xlUp).Row)
For Each Cell In Plage
If Cell.Value = "#" Then
Cell.Clear
End If
Next Cell
Dim c As Range
Dim firstAddress As String
Dim ChaineSelection As String
Dim I As Double
Application.ScreenUpdating = False
'efface les lignes contenant #
ChaineSelection = ""
With Range("C2", Range("C1000").End(xlUp).Address)
Set c = .Find("#", After:=Range("C2"))
If Not c Is Nothing Then
firstAddress = c.Address
Do
ChaineSelection = ChaineSelection & Range(c.Offset(0, -2), c.Offset(0, 2)).Address & ","
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
ChaineSelection = Mid(ChaineSelection, 1, Len(ChaineSelection) - 1)
Range(ChaineSelection).Delete shift:=xlUp
End If
End With
'insère les lignes avec des # autant de fois qu'il y a d'heures spécifiées
For I = Range("E1000").End(xlUp).Row To 2 Step -1
If Range("E1").Offset(I - 1, 0) > 1 Then
Range(Range("A1").Offset(I, 0), Range("E1").Offset(Range("E1").Offset(I - 1, 0) + I - 2, 0)).Insert shift:=xlDown
Range(Range("C1").Offset(I, 0), Range("C1").Offset(Range("E1").Offset(I - 1, 0) + I - 2, 0)) = "#"
End If
Next
'inscrie les jouurs de la semaine autant de fois qu'ils comportent d'heure
Dim vLigne As Double
vLigne = 1
For I = 1 To Range("J1000").End(xlUp).Row - 1
If Range("k1").Offset(I, 0) > 0 Then
Range(Range("G1").Offset(vLigne, 0), Range("G1").Offset(vLigne + Range("k1").Offset(I, 0) - 1, 0)) = Range("J1").Offset(I, 0)
vLigne = vLigne + Range("k1").Offset(I, 0)
End If
Next
' recopier la formule de H2 à H1000
Range("H2").Select
ActiveCell.FormulaR1C1 = "=IF(ISBLANK(RC[-4]),"""",RC[-4]-(RC[-1]+2))"
Range("H2:H1000").Select
Selection.FillDown
'enlever protection cellule
Range("A2:I1000").Select
Selection.Locked = False
'se positionner en B2
Range("B2").Select
Application.ScreenUpdating = True
End Sub