VBA ligne de commande alternative pour archiver
Bonjour,
je rencontre des problemes avec ma ligne de commande suivante:
shtArchivage.Rows(2).Insert Shift:=xlDown
Elle sert a supprimer une ligne dans la feuille 1 pour archiver dans une feuille 2, elle a tendance a faire planter mon tableau regulièrement.
Quelqu'un connaitrais une autre formule pour archiver mes lignes.
Merci d'avance.
Bonjour,
Ta commande ne supprime rien !
Elle insère une ligne en ligne 2 (et l'argument est d'ailleurs inutile puisque c'est une ligne entière que tu insères !)
Si elle apparaît en erreur, il faut savoir quelle erreur, et c'est probablement dues aux conditions dans lesquelles cette commande intervient.
Voila la formule complete que j'utilise :
Private Sub Worksheet_Change(ByVal Target As Range)
Dim aRange As Range
If (Target.Column = 19) Then
If (UCase(Target.Value) = "X") Then
Me.Rows(Target.Row).Copy
shtArchivage.Activate
shtArchivage.Rows(2).Insert Shift:=xlDown
Me.Activate
Me.Cells(Target.Row, 1).Value = ""
Me.Cells(Target.Row, 1).Hyperlinks.Delete
Me.Cells(Target.Row, 4).Value = ""
Me.Cells(Target.Row, 5).Value = ""
Me.Cells(Target.Row, 7).Value = ""
Me.Cells(Target.Row, 8).Value = ""
Me.Cells(Target.Row, 9).Value = ""
Me.Cells(Target.Row, 10).Value = ""
Me.Cells(Target.Row, 12).Value = ""
Me.Cells(Target.Row, 11).Value = ""
Me.Cells(Target.Row, 14).Value = ""
Me.Cells(Target.Row, 16).Value = ""
Me.Cells(Target.Row, 17).Value = ""
Me.Cells(Target.Row, 18).Value = ""
Me.Cells(Target.Row, 19).Value = ""
Me.Cells(Target.Row, 20).Value = ""
Me.Cells(Target.Row, 21).Value = ""
Me.Cells(Target.Row, 1).Borders.Weight = xlThin
Me.Cells(Target.Row, 1).HorizontalAlignment = xlCenter
Me.Cells(Target.Row, 1).VerticalAlignment = xlVAlignCenter
shtArchivage.Cells(2, 22).Value = Format(Now, "mm/dd/yyyy")
shtArchivage.Cells(2, 25).Value = 15
End If
End If
End Sub
Je teste les 2 lignes (activation de la feuille inutile) et elles fonctionnent telles quelles.
Donc quelque chose bloque sur ton classeur et empêche l'insertion.
de temps en temps j'ai ce message:
Partie réparée: partie /xl/worksheets/sheet5.xml avec erreur XML. Erreur de chargement. Ligne 2, colonne 0.
La solution trouvé de mon coté pour ceux que ça intéresse (avec des rajout perso divers pour la presentation) :
Sub Reset_Ligne()
Dim c As Range, cDest As Range
Application.ScreenUpdating = False
With ThisWorkbook
'cDest: La celllule de destination: première cellule vide de la colonne A de Archivage
With .Worksheets("Archivage")
Set cDest = .Cells(.Rows.Count, "A").End(xlUp)(2)
End With
With .Worksheets("Planning")
'on cherche LA CELLULE contenant x en colonne V de Feuille Planning
Set c = .Range("V:V").Find("x", LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
With c.EntireRow
'On copie toute la ligne trouvée vers cDest
.Copy cDest
'on supprime la ligne trouvée de Feuil1
.Delete
End With
Set c = Nothing
End If
'on vide notre variable cDest
Set cDest = Nothing
End With
Sheets("Archivage").Select
Cells.FormatConditions.Delete
Columns("A:A").Select
Selection.Hyperlinks.Delete
With Selection
.VerticalAlignment = xlTop
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
End With
Sheets("Planning").Select
End Sub
Sub Transfert()
Dim LastLig As Long
Dim sDest As Worksheet ' Feuille de destination
Dim cDest As Range ' Cellule de destination
Dim lCount As Long ' Nombre de cellule copié
Dim lFirst As Long ' Premiere cellule de date
Application.ScreenUpdating = False
With ThisWorkbook
'cDest: La celllule de destination: première cellule vide de la colonne A de Feuil2
Set sDest = .Worksheets("Archivage")
Set cDest = sDest.Cells(sDest.Rows.Count, "A").End(xlUp)(2)
With .Worksheets("Planning")
'Enlève l'éventuel filtre automatique
.AutoFilterMode = False
'LastLig, ligne de la dernière cellule remplie de colonne A de Archive
LastLig = .Cells(.Rows.Count, "A").End(xlUp).Row
'On fait un filtre automatique sur la colonne V de Planning avec comme critère "x"
.Range("V2:V" & LastLig).AutoFilter field:=1, Criteria1:="x"
'Si au moins une ligne résultat du filtre (en plus de la ligne 1 des titres)
lCount = .Range("V2:V" & LastLig).SpecialCells(xlCellTypeVisible).Count
If lCount > 1 Then
With .Range("V3:V" & LastLig).SpecialCells(xlCellTypeVisible).EntireRow
'On copie toutes les lignes visibles vers cDest (sauf la ligne des titres)
.Copy cDest
'on supprime toutes les lignes visibles (sauf la ligne des titres)
.Delete
End With
' On récupère la première cellule de la copie
lFirst = cDest.Rows(0).Row
' On écrit la date dans la plage définie
sDest.Range(sDest.Cells(lFirst, "U"), sDest.Cells(lFirst + (lCount - 1), "U")).Value = Format(Now, "dd/mm/yyyy")
sDest.Range(sDest.Cells(lFirst, "V"), sDest.Cells(lFirst + (lCount - 1), "V")).Value = Format(Now, "ww")
sDest.Range(sDest.Cells(lFirst, "W"), sDest.Cells(lFirst + (lCount - 1), "W")).Value = Format(Now, "yyyy")
sDest.Range(sDest.Cells(lFirst, "X"), sDest.Cells(lFirst + (lCount - 1), "X")).Value = 15
sDest.Range(sDest.Cells(lFirst, "A"), sDest.Cells(lFirst + (lCount - 1), "A")).Hyperlinks.Delete
sDest.Range(sDest.Cells(lFirst, "A"), sDest.Cells(lFirst + (lCount - 1), "A")).Font.Underline = False
sDest.Range(sDest.Cells(lFirst, "A"), sDest.Cells(lFirst + (lCount - 1), "A")).HorizontalAlignment = xlCenter
sDest.Range(sDest.Cells(lFirst, "A"), sDest.Cells(lFirst + (lCount - 1), "A")).Borders.Weight = xlThin
sDest.Range(sDest.Cells(lFirst, "A"), sDest.Cells(lFirst + (lCount - 1), "A")).VerticalAlignment = xlVAlignCenter
sDest.Range(sDest.Cells(lFirst, "U"), sDest.Cells(lFirst + (lCount - 1), "U")).HorizontalAlignment = xlCenter
sDest.Range(sDest.Cells(lFirst, "U"), sDest.Cells(lFirst + (lCount - 1), "U")).Borders.Weight = xlThin
sDest.Range(sDest.Cells(lFirst, "U"), sDest.Cells(lFirst + (lCount - 1), "U")).VerticalAlignment = xlVAlignCenter
sDest.Range(sDest.Cells(lFirst, "V"), sDest.Cells(lFirst + (lCount - 1), "V")).HorizontalAlignment = xlCenter
sDest.Range(sDest.Cells(lFirst, "V"), sDest.Cells(lFirst + (lCount - 1), "V")).Borders.Weight = xlThin
sDest.Range(sDest.Cells(lFirst, "V"), sDest.Cells(lFirst + (lCount - 1), "V")).VerticalAlignment = xlVAlignCenter
sDest.Range(sDest.Cells(lFirst, "W"), sDest.Cells(lFirst + (lCount - 1), "W")).HorizontalAlignment = xlCenter
sDest.Range(sDest.Cells(lFirst, "W"), sDest.Cells(lFirst + (lCount - 1), "W")).Borders.Weight = xlThin
sDest.Range(sDest.Cells(lFirst, "W"), sDest.Cells(lFirst + (lCount - 1), "W")).VerticalAlignment = xlVAlignCenter
sDest.Range(sDest.Cells(lFirst, "X"), sDest.Cells(lFirst + (lCount - 1), "X")).HorizontalAlignment = xlCenter
sDest.Range(sDest.Cells(lFirst, "X"), sDest.Cells(lFirst + (lCount - 1), "X")).Borders.Weight = xlThin
sDest.Range(sDest.Cells(lFirst, "X"), sDest.Cells(lFirst + (lCount - 1), "X")).VerticalAlignment = xlVAlignCenter
End If
'on vide notre variable cDest
Set cDest = Nothing
'On enlève le filtre automatique
.AutoFilterMode = False
End With
End With
Sheets("Archivage").Select
Cells.FormatConditions.Delete
Columns("A:A").Select
Selection.Hyperlinks.Delete
Sheets("Planning").Select
End Sub