Bonjour à tous,
J'utilise cette macro pour copier des lignes sur une autre feuille, cela fonctionne tres bien, par contre je voudrais toujours forcer l'ecriture en partant de la gauche pour la colonne A.
Si vous avez une idée .
Merci d'avance
J'utilise cette macro pour copier des lignes sur une autre feuille, cela fonctionne tres bien, par contre je voudrais toujours forcer l'ecriture en partant de la gauche pour la colonne A.
Si vous avez une idée .
Merci d'avance
Code:
Option Explicit
Dim sh5 As Worksheet
Dim sh6 As Worksheet
Sub HistoriqueCde()
Dim PlageCodes As Range, r As Range
Dim ModeCalcul
Dim cpt As Long 'compeur du nombre de lignes écrites
On Error GoTo FinEcritures
'Pour accélérer les écritures
ModeCalcul = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
'Références aux feuilles de travail
Set sh5 = Sheets("Pieces A Cder")
Set sh6 = Sheets("Historique Cde")
With sh5
' Réferences à la plage de cellules qui contient les codes
Set PlageCodes = .Range("D3:D" & .Range("D" & .Rows.Count).End(xlUp).Row)
End With
' Pour chaque ligne de la plage de code
For Each r In PlageCodes.Rows
' Ecriture des lignes si elles ne sont pas vides
If r.Cells(1, 1).Text >= 0 Then EcrireLigne r.Cells(1, 1): cpt = cpt + 1
Next r
FinEcritures:
' Rétablir la mise à jour écran
Application.ScreenUpdating = True
' Rétablir le mode de calcul par défaut
Application.Calculation = ModeCalcul
' Signaler une erreur éventuelle
If Err.Number > 0 Then
MsgBox Err.Description & vbCrLf & "Fin de la macro", vbExclamation, "LignesEcritures"
End If
End Sub
Private Sub EcrireLigne(c As Range)
Dim derLigne As Long
Dim cRow As Long
cRow = c.Row
On Error GoTo FinEcrireLigne
With sh6
derLigne = .Range("A" & .Rows.Count).End(xlUp).Row + 1
If derLigne = 2 Then derLigne = 3
.Cells(derLigne, 1) = sh5.Cells(cRow, 1)
.Cells(derLigne, 2) = sh5.Cells(cRow, 2)
.Cells(derLigne, 3) = sh5.Cells(cRow, 3)
.Cells(derLigne, 4) = sh5.Cells(cRow, 4)
.Cells(derLigne, 5) = Now
MiseEnForme .Range(.Cells(derLigne, 1), .Cells(derLigne, 5))
End With
FinEcrireLigne:
If Err.Number > 0 Then
MsgBox "Une erreur c'est produite pendant l'écriture de la ligne de compte n° " _
& c.Value, vbExclamation, "EcrireLigne"
End If
End Sub
Private Sub MiseEnForme(Cellules As Range)
On Error GoTo FinMiseEnForme
With Cellules
With .Interior
.ColorIndex = 2
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
With Cellules.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 1
End With
End With
FinMiseEnForme:
If Err.Number > 0 Then
MsgBox "une erreur s'est produite lors de la mise en forme de la ligne: " _
& Cellules.Row & vbCrLf & "sur la feuille " & sh6.Name, vbExclamation, "MiseEnForme"
End If
End Sub