Bonjour à tous
J'ai un code qui marche bien quand je l'éxécute en deux temps(sous forme de 2 macro, voir pièce jointe) par contre quand je l'éxécute sous forme d'une seule macro, il bloque à la ligne en rouge ci dessous. Mon code en 2 macros est en pièce jointe, merci de me dire où se trouve mon erreur
Le code:
Sub macro1()
Application.ScreenUpdating = False 'Pour accélérer la macro
'////// PARTIE 1 : SUPPRIMER LE SUPERFLU (mise en forme de base) //////
'Supprimer les feuilles superflues
Sheets(Array("anomalie VI pb BE", "anomalie SAP", "indicateur", "paramètre")). _
Select
Sheets("anomalie VI pb BE").Activate
ActiveWindow.SelectedSheets.Delete
'Supprimer tous ce qui n'est pas 'CIT' et 'DUP'
Selection.AutoFilter
ActiveSheet.Range("D").AutoFilter Field:=4, Criteria1:="="
ActiveSheet.Range("E:E").AutoFilter Field:=5, Criteria1:="="
Sheets("art sans doublon").Rows("2:65536").Delete
ActiveSheet.ShowAllData
'Création d'une nouvelle feuille "Montages sans doublon"
Sheets.Add after:=Sheets(Sheets.Count)
Sheets("feuil1").Name = "Montages sans doublon"
Sheets("art sans doublon").Select
Range("R1").AutoFilter Field:=18, Criteria1:="ZMON" 'Sélection de tous les 'ZMON'
Sheets("art sans doublon").Range("A:BU").Copy Destination:=Sheets("Montages sans doublon").Range("A1") 'Copier la sélection des 'ZMON' dans la nouvelle feuille crée
'Supprimer de la feuille tous les 'ZMON' sélectionné dans "art sans doublon"
Sheets("art sans doublon").Rows("2:65536").Delete
ActiveSheet.ShowAllData
'Insérer 8 nouvelles colonnes à partir de la colonne 'N'
Columns("N:U").Insert Shift:=xlToRight
'Récupérer la 1ère ligne du fichier "art acif base itc.xlsx"
With ThisWorkbook
Workbooks("art actif base itc.xlsx").Sheets("art sans doublon").Rows(1).Copy
.Sheets("art sans doublon").Rows(1).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.Sheets("art sans doublon").Paste
'////// PARTIE 2 : RECUPERER LES DONNEES DE LA SEMAINE PRECEDENTE (art.actif) //////'
'Récupérer les formules des colonnes O,P,Q,R,S,T,U,CE,CH,CF et CG
Range("O2:O" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC12,'[art actif base itc.xlsx]art sans doublon'!C12:C21,COLUMN(R1C)-11,FALSE)"
Selection.FillDown
Range("P2" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC12,'[art actif base itc.xlsx]art sans doublon'!C12:C21,COLUMN(R1C)-11,FALSE)"
Selection.FillDown
Range("Q2:Q" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC12,'[art actif base itc.xlsx]art sans doublon'!C12:C21,COLUMN(R1C)-11,FALSE)"
Selection.FillDown
Range("R2:R" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC12,'[art actif base itc.xlsx]art sans doublon'!C12:C21,COLUMN(R1C)-11,FALSE)"
Selection.FillDown
Range("S2:S" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC12,'[art actif base itc.xlsx]art sans doublon'!C12:C21,COLUMN(R1C)-11,FALSE)"
Selection.FillDown
Range("T2:T" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC12,'[art actif base itc.xlsx]art sans doublon'!C12:C21,COLUMN(R1C)-11,FALSE)"
Selection.FillDown
Range("U2:U" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC12,'[art actif base itc.xlsx]art sans doublon'!C12:C21,COLUMN(R1C)-11,FALSE)"
Selection.FillDown
Range("CE2:CE" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-71],'[art actif base itc.xlsx]art sans doublon'!C12:C83,71,FALSE)"
Selection.FillDown
Range("CH2:CH" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-74],'[art actif base itc.xlsx]art sans doublon'!C12:C86,75,FALSE)"
Selection.FillDown
Range("CF2:CF" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=IF(OR(RC[-17]=""X"",RC[-45]=""A""),""Oui"",""Non"")"
Selection.FillDown
Range("CG2:CG" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=IF(AND(RC[-81]=1,RC[-80]=1),""CIT et DUP"",IF(RC[-81]=1,""CIT"",IF(RC[-80]=1,""DUP"",0)))"
Selection.FillDown
'Formules maintenant récupérées !
'Ecraser les formules et ne garder que les valeurs dans les colonnes O,P,Q,R,S,T et U
Columns("O:U").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Ecraser les formules et ne garder que les valeurs dans les colonnes CE,CF,CG et CH
Columns("CE:CH").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' ////// PARTIE 3: RECUPERER LES DONNEES DE COUVERTURE //////
'Récupérer la formule de la colonne CD
Range("CD2:CD" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-70],[COMPILATION_COUVERTURE.xls]BASE!C7:C71,19,FALSE)"
Selection.FillDown
'Ecraser les formules de la colonne CD
Columns("CD:CD").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Supprimer les fournisseurs (1plus, 1stock et vides) dans la colonne AN de "COMPILATION_COUVERTURE.xls"
Windows("COMPILATION_COUVERTURE.xls").Activate
Range("AN2").AutoFilter
Range("AN2").AutoFilter Field:=40, Criteria1:=Array( _
"1-plus de 1BNC et pas bes. EBI => article couvert", "1-stock sur bes EBI", "=") _
, Operator:=xlFilterValues
Sheets("BASE").Rows("3:65536").Delete
ActiveSheet.ShowAllData
End With
Application.ScreenUpdating = True 'Pour accélérer la macro
End Sub
Sub macro2()
Application.ScreenUpdating = False 'Pour accélérer la macro
'Récupérer la formule de la colonne N
Range("N2:N" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-2],[COMPILATION_COUVERTURE.xls]BASE!C7:C60,34,FALSE)"
Selection.FillDown
'Sélectionner les #N/A dans les colonnes CH,N,O,P,Q,R,S,T et U et les modifier par les numéro de la semaine en cours
Dim i, ligne_fin As Integer
Dim sem As String
Application.Calculation = xlCalculationManual
sem = "S" & (Format(Date, "yy\0\0") + DatePart("ww", Date, 2, 2))
ligne_fin = Sheets("art sans doublon").Cells(65536, 12).End(xlUp).Row
For i = 2 To ligne_fin
If IsError(Cells(i, 86)) Then Cells(i, 86) = sem
If IsError(Cells(i, 15)) Then Cells(i, 15) = "?" & " " & sem
If IsError(Cells(i, 16)) Then Cells(i, 16) = "?" & " " & sem
If IsError(Cells(i, 17)) Then Cells(i, 17) = "?" & " " & sem
If IsError(Cells(i, 18)) Then Cells(i, 18) = "?" & " " & sem
If IsError(Cells(i, 19)) Then Cells(i, 19) = "?" & " " & sem
If IsError(Cells(i, 20)) Then Cells(i, 20) = "?" & " " & sem
If IsError(Cells(i, 21)) Then Cells(i, 21) = "?" & " " & sem
If IsError(Cells(i, 14)) Then Cells(i, 14) = "?"
Next
Application.Calculation = xlCalculationAutomatic
'Ecraser les formules de la colonne N
Columns("N:N").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' ////// PARTIE 4: MISE EN FORME FINALE //////
'Mettre les colonnes D,E,AE,AM et BO en orange et centré
'Mettre les colonnes D et E en orange et centré
Range("D1:E" & Range("A65536").End(xlUp).Row).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection
.HorizontalAlignment = xlGeneral
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Mettre la colonne AE en orange et centré
Range("AE1:AE" & Range("A65536").End(xlUp).Row).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection
.HorizontalAlignment = xlGeneral
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Mettre la colonne AM en orange et centré
Range("AM1:AM" & Range("A65536").End(xlUp).Row).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection
.HorizontalAlignment = xlGeneral
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Mettre la colonne BO en orange et centré
Range("BO1:BO" & Range("A65536").End(xlUp).Row).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection
.HorizontalAlignment = xlGeneral
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Mettre les colonnes N,CD et CE en orange
'Mettre la colonne N en orange
Range("N1:N" & Range("A65536").End(xlUp).Row).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Mettre les colonnes CD et CE en orange
Range("CD1:CE" & Range("A65536").End(xlUp).Row).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Mettre les colonnes O,P,Q,R,S,T et U en jaune
Range("O1:U" & Range("A65536").End(xlUp).Row).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Centrer les colonnes P,R et T
'Centrer la colonne P
Range("P1" & Range("A65536").End(xlUp).Row).Select
With Selection
.HorizontalAlignment = xlGeneral
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Centrer la colonne R
Range("R1:R" & Range("A65536").End(xlUp).Row).Select
With Selection
.HorizontalAlignment = xlGeneral
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Centrer la colonne T
Range("T1:T" & Range("A65536").End(xlUp).Row).Select
With Selection
.HorizontalAlignment = xlGeneral
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Mettre une bordure au tableau
ActiveSheet.UsedRange.Select
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
'Copier la liste de choix
With ThisWorkbook
Workbooks("art actif base itc.xlsx").Sheets("Listes de choix").Copy Before:=.Sheets(1)
'Mettre la validation de données des colonnes O,Q,R,S,T et U
'Mettre la validation de données de la colonne O
Sheets("art sans doublon").Select
Range("O1:O" & Range("A65536").End(xlUp).Row).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="='Listes de choix'!$A$2:$A$6"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
'Mettre la validation de données de la colonne Q
Range("Q1:Q" & Range("A65536").End(xlUp).Row).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="='Listes de choix'!$A$9:$A$16"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = False
End With
'Mettre la validation de données de la colonne R
Range("R1:R" & Range("A65536").End(xlUp).Row).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="='Listes de choix'!$A$19:$A$21"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
'Mettre la validation de données de la colonne S
Range("S1:S" & Range("A65536").End(xlUp).Row).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="='Listes de choix'!$A$24:$A$35"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = False
End With
'Mettre la validation de données de la colonne T
Range("T1:T" & Range("A65536").End(xlUp).Row).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="='Listes de choix'!$A$38:$A$40"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
'Mettre la validation de données de la colonne U
Range("U1:U" & Range("A65536").End(xlUp).Row).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="='Listes de choix'!$A$43:$A$54"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = False
End With
'Macro permettant de nettoyer pour optimiser la taille du classeur après application de macros
Dim Sht As Worksheet, DCell As Range, Calc As Long, Rien As String
On Error Resume Next
Calc = Application.Calculation
With Application
.Calculation = xlCalculationManual
.StatusBar = "Nettoyage en cours..."
.EnableCancelKey = xlErrorHandler
.ScreenUpdating = False
End With
For Each Sht In Worksheets
If Sht.UsedRange.Address <> "$A$1" Or Not IsEmpty(Sht.[A1]) Then
Set DCell = Sht.Cells.Find("*", , , , xlByRows, xlPrevious)(2)
If Not DCell Is Nothing Then
Sht.Range(DCell, Sht.Cells([A:A].Count, 1)).EntireRow.Delete
Set DCell = Nothing
Set DCell = Sht.Cells.Find("*", , , , xlByColumns, xlPrevious)(, 2)
If Not DCell Is Nothing Then _
Sht.Range(DCell, Sht.[IV1]).EntireColumn.Delete
End If
Rien = Sht.UsedRange.Address
End If
Next Sht
Application.StatusBar = False
Application.Calculation = Calc
End With
Application.ScreenUpdating = True 'Pour accélérer la macro
End Sub
J'ai un code qui marche bien quand je l'éxécute en deux temps(sous forme de 2 macro, voir pièce jointe) par contre quand je l'éxécute sous forme d'une seule macro, il bloque à la ligne en rouge ci dessous. Mon code en 2 macros est en pièce jointe, merci de me dire où se trouve mon erreur
Le code:
Sub macro1()
Application.ScreenUpdating = False 'Pour accélérer la macro
'////// PARTIE 1 : SUPPRIMER LE SUPERFLU (mise en forme de base) //////
'Supprimer les feuilles superflues
Sheets(Array("anomalie VI pb BE", "anomalie SAP", "indicateur", "paramètre")). _
Select
Sheets("anomalie VI pb BE").Activate
ActiveWindow.SelectedSheets.Delete
'Supprimer tous ce qui n'est pas 'CIT' et 'DUP'
Selection.AutoFilter
ActiveSheet.Range("D").AutoFilter Field:=4, Criteria1:="="
ActiveSheet.Range("E:E").AutoFilter Field:=5, Criteria1:="="
Sheets("art sans doublon").Rows("2:65536").Delete
ActiveSheet.ShowAllData
'Création d'une nouvelle feuille "Montages sans doublon"
Sheets.Add after:=Sheets(Sheets.Count)
Sheets("feuil1").Name = "Montages sans doublon"
Sheets("art sans doublon").Select
Range("R1").AutoFilter Field:=18, Criteria1:="ZMON" 'Sélection de tous les 'ZMON'
Sheets("art sans doublon").Range("A:BU").Copy Destination:=Sheets("Montages sans doublon").Range("A1") 'Copier la sélection des 'ZMON' dans la nouvelle feuille crée
'Supprimer de la feuille tous les 'ZMON' sélectionné dans "art sans doublon"
Sheets("art sans doublon").Rows("2:65536").Delete
ActiveSheet.ShowAllData
'Insérer 8 nouvelles colonnes à partir de la colonne 'N'
Columns("N:U").Insert Shift:=xlToRight
'Récupérer la 1ère ligne du fichier "art acif base itc.xlsx"
With ThisWorkbook
Workbooks("art actif base itc.xlsx").Sheets("art sans doublon").Rows(1).Copy
.Sheets("art sans doublon").Rows(1).PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.Sheets("art sans doublon").Paste
'////// PARTIE 2 : RECUPERER LES DONNEES DE LA SEMAINE PRECEDENTE (art.actif) //////'
'Récupérer les formules des colonnes O,P,Q,R,S,T,U,CE,CH,CF et CG
Range("O2:O" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC12,'[art actif base itc.xlsx]art sans doublon'!C12:C21,COLUMN(R1C)-11,FALSE)"
Selection.FillDown
Range("P2" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC12,'[art actif base itc.xlsx]art sans doublon'!C12:C21,COLUMN(R1C)-11,FALSE)"
Selection.FillDown
Range("Q2:Q" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC12,'[art actif base itc.xlsx]art sans doublon'!C12:C21,COLUMN(R1C)-11,FALSE)"
Selection.FillDown
Range("R2:R" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC12,'[art actif base itc.xlsx]art sans doublon'!C12:C21,COLUMN(R1C)-11,FALSE)"
Selection.FillDown
Range("S2:S" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC12,'[art actif base itc.xlsx]art sans doublon'!C12:C21,COLUMN(R1C)-11,FALSE)"
Selection.FillDown
Range("T2:T" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC12,'[art actif base itc.xlsx]art sans doublon'!C12:C21,COLUMN(R1C)-11,FALSE)"
Selection.FillDown
Range("U2:U" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC12,'[art actif base itc.xlsx]art sans doublon'!C12:C21,COLUMN(R1C)-11,FALSE)"
Selection.FillDown
Range("CE2:CE" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-71],'[art actif base itc.xlsx]art sans doublon'!C12:C83,71,FALSE)"
Selection.FillDown
Range("CH2:CH" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-74],'[art actif base itc.xlsx]art sans doublon'!C12:C86,75,FALSE)"
Selection.FillDown
Range("CF2:CF" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=IF(OR(RC[-17]=""X"",RC[-45]=""A""),""Oui"",""Non"")"
Selection.FillDown
Range("CG2:CG" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=IF(AND(RC[-81]=1,RC[-80]=1),""CIT et DUP"",IF(RC[-81]=1,""CIT"",IF(RC[-80]=1,""DUP"",0)))"
Selection.FillDown
'Formules maintenant récupérées !
'Ecraser les formules et ne garder que les valeurs dans les colonnes O,P,Q,R,S,T et U
Columns("O:U").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Ecraser les formules et ne garder que les valeurs dans les colonnes CE,CF,CG et CH
Columns("CE:CH").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' ////// PARTIE 3: RECUPERER LES DONNEES DE COUVERTURE //////
'Récupérer la formule de la colonne CD
Range("CD2:CD" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-70],[COMPILATION_COUVERTURE.xls]BASE!C7:C71,19,FALSE)"
Selection.FillDown
'Ecraser les formules de la colonne CD
Columns("CD:CD").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Supprimer les fournisseurs (1plus, 1stock et vides) dans la colonne AN de "COMPILATION_COUVERTURE.xls"
Windows("COMPILATION_COUVERTURE.xls").Activate
Range("AN2").AutoFilter
Range("AN2").AutoFilter Field:=40, Criteria1:=Array( _
"1-plus de 1BNC et pas bes. EBI => article couvert", "1-stock sur bes EBI", "=") _
, Operator:=xlFilterValues
Sheets("BASE").Rows("3:65536").Delete
ActiveSheet.ShowAllData
End With
Application.ScreenUpdating = True 'Pour accélérer la macro
End Sub
Sub macro2()
Application.ScreenUpdating = False 'Pour accélérer la macro
'Récupérer la formule de la colonne N
Range("N2:N" & Range("A65536").End(xlUp).Row).Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-2],[COMPILATION_COUVERTURE.xls]BASE!C7:C60,34,FALSE)"
Selection.FillDown
'Sélectionner les #N/A dans les colonnes CH,N,O,P,Q,R,S,T et U et les modifier par les numéro de la semaine en cours
Dim i, ligne_fin As Integer
Dim sem As String
Application.Calculation = xlCalculationManual
sem = "S" & (Format(Date, "yy\0\0") + DatePart("ww", Date, 2, 2))
ligne_fin = Sheets("art sans doublon").Cells(65536, 12).End(xlUp).Row
For i = 2 To ligne_fin
If IsError(Cells(i, 86)) Then Cells(i, 86) = sem
If IsError(Cells(i, 15)) Then Cells(i, 15) = "?" & " " & sem
If IsError(Cells(i, 16)) Then Cells(i, 16) = "?" & " " & sem
If IsError(Cells(i, 17)) Then Cells(i, 17) = "?" & " " & sem
If IsError(Cells(i, 18)) Then Cells(i, 18) = "?" & " " & sem
If IsError(Cells(i, 19)) Then Cells(i, 19) = "?" & " " & sem
If IsError(Cells(i, 20)) Then Cells(i, 20) = "?" & " " & sem
If IsError(Cells(i, 21)) Then Cells(i, 21) = "?" & " " & sem
If IsError(Cells(i, 14)) Then Cells(i, 14) = "?"
Next
Application.Calculation = xlCalculationAutomatic
'Ecraser les formules de la colonne N
Columns("N:N").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
' ////// PARTIE 4: MISE EN FORME FINALE //////
'Mettre les colonnes D,E,AE,AM et BO en orange et centré
'Mettre les colonnes D et E en orange et centré
Range("D1:E" & Range("A65536").End(xlUp).Row).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection
.HorizontalAlignment = xlGeneral
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Mettre la colonne AE en orange et centré
Range("AE1:AE" & Range("A65536").End(xlUp).Row).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection
.HorizontalAlignment = xlGeneral
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Mettre la colonne AM en orange et centré
Range("AM1:AM" & Range("A65536").End(xlUp).Row).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection
.HorizontalAlignment = xlGeneral
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Mettre la colonne BO en orange et centré
Range("BO1:BO" & Range("A65536").End(xlUp).Row).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection
.HorizontalAlignment = xlGeneral
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Mettre les colonnes N,CD et CE en orange
'Mettre la colonne N en orange
Range("N1:N" & Range("A65536").End(xlUp).Row).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Mettre les colonnes CD et CE en orange
Range("CD1:CE" & Range("A65536").End(xlUp).Row).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 49407
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Mettre les colonnes O,P,Q,R,S,T et U en jaune
Range("O1:U" & Range("A65536").End(xlUp).Row).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
'Centrer les colonnes P,R et T
'Centrer la colonne P
Range("P1" & Range("A65536").End(xlUp).Row).Select
With Selection
.HorizontalAlignment = xlGeneral
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Centrer la colonne R
Range("R1:R" & Range("A65536").End(xlUp).Row).Select
With Selection
.HorizontalAlignment = xlGeneral
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Centrer la colonne T
Range("T1:T" & Range("A65536").End(xlUp).Row).Select
With Selection
.HorizontalAlignment = xlGeneral
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Mettre une bordure au tableau
ActiveSheet.UsedRange.Select
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
'Copier la liste de choix
With ThisWorkbook
Workbooks("art actif base itc.xlsx").Sheets("Listes de choix").Copy Before:=.Sheets(1)
'Mettre la validation de données des colonnes O,Q,R,S,T et U
'Mettre la validation de données de la colonne O
Sheets("art sans doublon").Select
Range("O1:O" & Range("A65536").End(xlUp).Row).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="='Listes de choix'!$A$2:$A$6"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
'Mettre la validation de données de la colonne Q
Range("Q1:Q" & Range("A65536").End(xlUp).Row).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="='Listes de choix'!$A$9:$A$16"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = False
End With
'Mettre la validation de données de la colonne R
Range("R1:R" & Range("A65536").End(xlUp).Row).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="='Listes de choix'!$A$19:$A$21"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
'Mettre la validation de données de la colonne S
Range("S1:S" & Range("A65536").End(xlUp).Row).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="='Listes de choix'!$A$24:$A$35"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = False
End With
'Mettre la validation de données de la colonne T
Range("T1:T" & Range("A65536").End(xlUp).Row).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="='Listes de choix'!$A$38:$A$40"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
'Mettre la validation de données de la colonne U
Range("U1:U" & Range("A65536").End(xlUp).Row).Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="='Listes de choix'!$A$43:$A$54"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = False
End With
'Macro permettant de nettoyer pour optimiser la taille du classeur après application de macros
Dim Sht As Worksheet, DCell As Range, Calc As Long, Rien As String
On Error Resume Next
Calc = Application.Calculation
With Application
.Calculation = xlCalculationManual
.StatusBar = "Nettoyage en cours..."
.EnableCancelKey = xlErrorHandler
.ScreenUpdating = False
End With
For Each Sht In Worksheets
If Sht.UsedRange.Address <> "$A$1" Or Not IsEmpty(Sht.[A1]) Then
Set DCell = Sht.Cells.Find("*", , , , xlByRows, xlPrevious)(2)
If Not DCell Is Nothing Then
Sht.Range(DCell, Sht.Cells([A:A].Count, 1)).EntireRow.Delete
Set DCell = Nothing
Set DCell = Sht.Cells.Find("*", , , , xlByColumns, xlPrevious)(, 2)
If Not DCell Is Nothing Then _
Sht.Range(DCell, Sht.[IV1]).EntireColumn.Delete
End If
Rien = Sht.UsedRange.Address
End If
Next Sht
Application.StatusBar = False
Application.Calculation = Calc
End With
Application.ScreenUpdating = True 'Pour accélérer la macro
End Sub
Pièces jointes
Dernière édition: