Diviser une macro en 2
Bonjour à tous,
J'ai la macro ci dessous qui fait 2 opérations :
1.) decoupe certaines lignes et les copies dans une autre deuille
2.) recopie les formules sur les 500 premieres lignes.
Je souhaiterai separer ces tâches et faire en fait 2 macro différentes, mais lorsque j'essai il y a des problemes de syntaxe.
Je souhaiterai egalement pour la deuxieme partie copier les formules sur les 500 premieres lignes vides, et non plus les 500 premieres lignes.
Si quelqu'un aurait une idee
Voici la macro en question :
Option Explicit
Sub Archivage()
Dim i As Long, DerLig As Long, PremLig As Long
Application.ScreenUpdating = False
With Sheets("Besoins")
DerLig = Application.Max(.Range("A" & Rows.Count).End(xlUp).Row, 2)
For i = DerLig To 2 Step -1
If .Range("R" & i) <> "" Then
PremLig = Sheets("Archives").Range("B" & Rows.Count).End(xlUp).Row + 1
Sheets("Archives").Range("B" & PremLig & ":R" & PremLig).Value = .Range("B" & i & ":R" & i).Value
.Range("A" & i & ":R" & i).Delete
End If
Next i
For i = 2 To 2500
Cells(i, 1).FormulaR1C1 = "=IF(RC[1]="""","""",IF(RC[1]=R[-1]C[1],R[-1]C,R[-1]C+1))"
If IsEmpty(.Cells(i, 11)) Then .Cells(i, 11).FormulaR1C1 = "=IF(RC1="""","""",IFERROR(VLOOKUP(RC2,'Stock proto'!C2:C3,2,False),0))"
If IsEmpty(.Cells(i, 12)) Then .Cells(i, 12).FormulaR1C1 = "=IF(RC[-11]="""","""",IF(RC[-3]-RC[-1]<0,0,RC[-3]-RC[-1]))"
If IsEmpty(.Cells(i, 13)) Then .Cells(i, 13).FormulaR1C1 = "=IF(RC[-12]="""","""",IF(RC[-1]=0,"""",""job à créer""))"
If IsEmpty(.Cells(i, 15)) Then .Cells(i, 15).FormulaR1C1 = "=IF(RC[-14]="""","""",IF(COUNTIF(C[-8]:C[-8],RC[-8])>1,(SUMIF(C[-8]:C[-6],RC[-8],C[-6]:C[-6])-SUMIF(C[-8]:C[-1],RC[-8],C[-1]:C[-1])),""""))"
If IsEmpty(.Cells(i, 17)) Then .Cells(i, 17).FormulaR1C1 = "=IF(AND(RC[-11]<TODAY(),RC[-1]<TODAY(),RC[-1]<>""""),""Retard composant et livraison"",IF(AND(RC[-11]<TODAY(),RC[-11]<>""""),""Retard livraison"",IF(AND(RC[-1]<>"""",RC[-1]<TODAY()),""Retard composant"","""")))"
Next i
End With
Application.ScreenUpdating = True
End Sub
Bonjour,
Un essai ...
Option Explicit
Sub Archivage()
Dim i As Long, DerLig As Long, PremLig As Long
Application.ScreenUpdating = False
With Sheets("Besoins")
DerLig = Application.Max(.Range("A" & Rows.Count).End(xlUp).Row, 2)
For i = DerLig To 2 Step -1
If .Range("R" & i) <> "" Then
PremLig = Sheets("Archives").Range("B" & Rows.Count).End(xlUp).Row + 1
Sheets("Archives").Range("B" & PremLig & ":R" & PremLig).Value = .Range("B" & i & ":R" & i).Value
.Range("A" & i & ":R" & i).Delete
End If
Next i
End With
End Sub
Sub CopieLesLignes()
Dim i As Long, DerLig As Long
Application.ScreenUpdating = False
With Sheets("Besoins")
DerLig = .Cells(Rows.Count, "A").End(xlUp).Row + 1
For i = DerLig To DerLig + 500
.Cells(i, 1).FormulaR1C1 = "=IF(RC[1]="""","""",IF(RC[1]=R[-1]C[1],R[-1]C,R[-1]C+1))"
If IsEmpty(.Cells(i, 11)) Then .Cells(i, 11).FormulaR1C1 = "=IF(RC1="""","""",IFERROR(VLOOKUP(RC2,'Stock proto'!C2:C3,2,False),0))"
If IsEmpty(.Cells(i, 12)) Then .Cells(i, 12).FormulaR1C1 = "=IF(RC[-11]="""","""",IF(RC[-3]-RC[-1]<0,0,RC[-3]-RC[-1]))"
If IsEmpty(.Cells(i, 13)) Then .Cells(i, 13).FormulaR1C1 = "=IF(RC[-12]="""","""",IF(RC[-1]=0,"""",""job à créer""))"
If IsEmpty(.Cells(i, 15)) Then .Cells(i, 15).FormulaR1C1 = "=IF(RC[-14]="""","""",IF(COUNTIF(C[-8]:C[-8],RC[-8])>1,(SUMIF(C[-8]:C[-6],RC[-8],C[-6]:C[-6])-SUMIF(C[-8]:C[-1],RC[-8],C[-1]:C[-1])),""""))"
If IsEmpty(.Cells(i, 17)) Then .Cells(i, 17).FormulaR1C1 = "=IF(AND(RC[-11]<TODAY(),RC[-1]<TODAY(),RC[-1]<>""""),""Retard composant et livraison"",IF(AND(RC[-11]<TODAY(),RC[-11]<>""""),""Retard livraison"",IF(AND(RC[-1]<>"""",RC[-1]<TODAY()),""Retard composant"","""")))"
Next i
End With
End Subric
Bonjour,
Désolé, je n'ai pas pu répondre plus vite.
Merci, ca fonctionne bien.
Par contre, pour la formule couper/copier, est il possible d'ajouter un tri du fichier à la fin ?
J'aimerai faire un tri sur les colonnes :
- colonne F
- colonne B
- colonne K
- colonne G
Je remet la formule à jour si dessous
Merci
Option Explicit
Sub Archivage()
Dim I As Long, DerLig As Long, PremLig As Long
Application.ScreenUpdating = False
With Sheets("Besoins")
DerLig = Application.Max(.Range("A" & Rows.Count).End(xlUp).Row, 2)
For I = DerLig To 2 Step -1
If .Range("W" & I) <> "" Then
PremLig = Sheets("Archives mois en cours").Range("B" & Rows.Count).End(xlUp).Row + 1
Sheets("Archives mois en cours").Range("B" & PremLig & ":W" & PremLig).Value = .Range("B" & I & ":W" & I).Value
.Range("B" & I & ":W" & I).Delete
End If
Next I
End With
End Sub
Bonjour,
Ce que je comprends, c'est que tu veux ce tri sur la feuille " Archives mois en cours " quand la copie des données est terminée ... triée sur la colonne F, puis B, puis K et enfin G...
Un essai ...
Option Explicit
Sub Archivage()
Dim I As Long, DerLig As Long, PremLig As Long
Application.ScreenUpdating = False
With Sheets("Besoins")
DerLig = Application.Max(.Range("A" & Rows.Count).End(xlUp).Row, 2)
For I = DerLig To 2 Step -1
If .Range("W" & I) <> "" Then
PremLig = Sheets("Archives mois en cours").Range("B" & Rows.Count).End(xlUp).Row + 1
Sheets("Archives mois en cours").Range("B" & PremLig & ":W" & PremLig).Value = .Range("B" & I & ":W" & I).Value
.Range("B" & I & ":W" & I).Delete
End If
Next I
End With
With Worksheets("Archives mois en cours")
.Activate
DerLig = Cells(Rows.Count, "W").End(xlUp).Row
.Sort.SortFields.Clear
.Sort.SortFields.Add2 Key:=Range("F1:F" & DerLig) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add2 Key:=Range("B1:B" & DerLig) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add2 Key:=Range("K1:K" & DerLig) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add2 Key:=Range("G1:G" & DerLig) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("A1:W" & DerLig)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
End Subric
Merci RIC,
Désolé j'aurai du etre plus precis.
En fait je souhaiterai que les données couper/coller concernent les colonnes de B>W. (donc coller à partir de la colonne B sur la feuille "Archives mois en cours")
Apres suppression de B>W dans la feuille (Besoins), faire le tri sur cette même feuille.
J'ai changé le nom de la feuille dans ta formule et essayer de ne pas couper/coller la colonne A mais sans succes.
Bonjour,
Un autre essai ...
C'est la feuille "Besoins" qui sera triée après le traitement.
Option Explicit
Sub Archivage()
Dim I As Long, DerLig As Long, PremLig As Long
Application.ScreenUpdating = False
With Sheets("Besoins")
DerLig = Application.Max(.Range("A" & Rows.Count).End(xlUp).Row, 2)
For I = DerLig To 2 Step -1
If .Range("W" & I) <> "" Then
PremLig = Sheets("Archives mois en cours").Range("B" & Rows.Count).End(xlUp).Row + 1
Sheets("Archives mois en cours").Range("B" & PremLig & ":W" & PremLig).Value = .Range("B" & I & ":W" & I).Value
.Range("B" & I & ":W" & I).Delete
End If
Next I
.Activate ' active la feuille au besoin
DerLig = Cells(Rows.Count, "B").End(xlUp).Row ' trouve la dernière ligne de la colonne B < ajuster au besoin
.Sort.SortFields.Clear ' en préparation du nouveau tri
' détermine les filtres du tri
.Sort.SortFields.Add2 Key:=Range("F1:F" & DerLig) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add2 Key:=Range("B1:B" & DerLig) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add2 Key:=Range("K1:K" & DerLig) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add2 Key:=Range("G1:G" & DerLig) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort ' prépare le tri
.SetRange Range("A1:W" & DerLig) ' de la colonne A à la colonne W
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply ' applique le tri
End With
End With
End Subric
Merci RIC, c est parfait.
Si je peux t en demander une dernier stp :
J'aimerai ajouter à la macro "CopieLesLignes" que cette formule doit etre appliqué sur toutes les lignes de la colonne "A" non vides :
.Cells(I, 1).FormulaR1C1 = "=IF(RC[1]="""","""",IF(RC[1]=R[-1]C[1],R[-1]C,R[-1]C+1))"
C'est possible ?
Bonjour,
Dois-je comprendre que la formule doit être ajoutée aux cellules de la colonne A de la feuille "Archives mois en cours" ?
ric
Non dans la feuille "Besoins", il faudrait l'inclure à cette macro :
Sub CopieLesLignes()
Dim i As Long, DerLig As Long
Application.ScreenUpdating = False
With Sheets("Besoins")
DerLig = .Cells(Rows.Count, "A").End(xlUp).Row + 1
For i = DerLig To DerLig + 500
.Cells(i, 1).FormulaR1C1 = "=IF(RC[1]="""","""",IF(RC[1]=R[-1]C[1],R[-1]C,R[-1]C+1))"
If IsEmpty(.Cells(i, 11)) Then .Cells(i, 11).FormulaR1C1 = "=IF(RC1="""","""",IFERROR(VLOOKUP(RC2,'Stock proto'!C2:C3,2,False),0))"
If IsEmpty(.Cells(i, 12)) Then .Cells(i, 12).FormulaR1C1 = "=IF(RC[-11]="""","""",IF(RC[-3]-RC[-1]<0,0,RC[-3]-RC[-1]))"
If IsEmpty(.Cells(i, 13)) Then .Cells(i, 13).FormulaR1C1 = "=IF(RC[-12]="""","""",IF(RC[-1]=0,"""",""job à créer""))"
If IsEmpty(.Cells(i, 15)) Then .Cells(i, 15).FormulaR1C1 = "=IF(RC[-14]="""","""",IF(COUNTIF(C[-8]:C[-8],RC[-8])>1,(SUMIF(C[-8]:C[-6],RC[-8],C[-6]:C[-6])-SUMIF(C[-8]:C[-1],RC[-8],C[-1]:C[-1])),""""))"
If IsEmpty(.Cells(i, 17)) Then .Cells(i, 17).FormulaR1C1 = "=IF(AND(RC[-11]<TODAY(),RC[-1]<TODAY(),RC[-1]<>""""),""Retard composant et livraison"",IF(AND(RC[-11]<TODAY(),RC[-11]<>""""),""Retard livraison"",IF(AND(RC[-1]<>"""",RC[-1]<TODAY()),""Retard composant"","""")))"
Next i
End With
End Sub
En fait, lorsque je fais un couper/coller ca me met en erreur les formules en colonne A (+ la mise en forme conditionnelle....).
Je souhaite donc recopier la formule sur toutes les lignes non vides
En fait, lorsque je fais un couper/coller ca me met en erreur les formules en colonne A (+ la mise en forme conditionnelle....).
Je souhaite donc recopier la formule sur toutes les lignes non vides
Bonjour,
un essai...
3 lignes ajoutées sous With ...
Sub CopieLesLignes()
Dim i As Long, DerLig As Long
Application.ScreenUpdating = False
With Sheets("Besoins")
' début de l'ajout
DerLig = .Cells(Rows.Count, "A").End(xlUp).Row
Set Plage = .Range("A2:A" & DerLig)
Plage.FormulaR1C1 = "=IF(RC[1]="""","""",IF(RC[1]=R[-1]C[1],R[-1]C,R[-1]C+1))"
' fin de l'ajout
DerLig = DerLig + 1
For i = DerLig To DerLig + 500
.Cells(i, 1).FormulaR1C1 = "=IF(RC[1]="""","""",IF(RC[1]=R[-1]C[1],R[-1]C,R[-1]C+1))"
If IsEmpty(.Cells(i, 11)) Then .Cells(i, 11).FormulaR1C1 = "=IF(RC1="""","""",IFERROR(VLOOKUP(RC2,'Stock proto'!C2:C3,2,False),0))"
If IsEmpty(.Cells(i, 12)) Then .Cells(i, 12).FormulaR1C1 = "=IF(RC[-11]="""","""",IF(RC[-3]-RC[-1]<0,0,RC[-3]-RC[-1]))"
If IsEmpty(.Cells(i, 13)) Then .Cells(i, 13).FormulaR1C1 = "=IF(RC[-12]="""","""",IF(RC[-1]=0,"""",""job à créer""))"
If IsEmpty(.Cells(i, 15)) Then .Cells(i, 15).FormulaR1C1 = "=IF(RC[-14]="""","""",IF(COUNTIF(C[-8]:C[-8],RC[-8])>1,(SUMIF(C[-8]:C[-6],RC[-8],C[-6]:C[-6])-SUMIF(C[-8]:C[-1],RC[-8],C[-1]:C[-1])),""""))"
If IsEmpty(.Cells(i, 17)) Then .Cells(i, 17).FormulaR1C1 = "=IF(AND(RC[-11]<TODAY(),RC[-1]<TODAY(),RC[-1]<>""""),""Retard composant et livraison"",IF(AND(RC[-11]<TODAY(),RC[-11]<>""""),""Retard livraison"",IF(AND(RC[-1]<>"""",RC[-1]<TODAY()),""Retard composant"","""")))"
Next i
End With
End Subric
Ca marche,
Merci beaucoup