Autres ActiveWorkbook.Worksheets("vierge").AutoFilter.Sort.SortFields.Clear

SAAD doli · 28 Mars 2023

Bonjour j'essaie d'optimiser un projet vba
J'ai commencé par réduire les selects
un erreur parait toujours je sais pas pourquoi
merci si vous pouvez me proposer des optimisations du code
Sub Macro1()
'
' Macro1 Macro
'
' Sub Miseàjour()
'
' Miseàjour Macro
'

' Suppression Filtre
Sheets("FS_semaine N").Select
Rows("1:1").Select
Selection.AutoFilter

' Arrangement onglet vierge (ordre croissant et colonnes rangées)
Sheets("vierge").Select
Cells.Select
' Selection.Columns.Ungroup
Columns("A:CJ").Select
Selection.EntireColumn.Hidden = False
Rows("1:7").Delete Shift:=xlUp
Cells.Select
With Selection
.WrapText = True
.Orientation = 0
.AddIndent = False
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("Y2").FormulaR1C1 = _
"=IF(ISBLANK(R[1]C[-10]),CONCATENATE(RC[-1],"" "",R[1]C[-1]),RC[-1])"
Range("Y2").AutoFill Destination:=Range("Y2:Y10000"), Type:=xlFillDefault
Columns("Y:Y").Copy
Columns("Y:Y").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("Y:Y").Select
Application.CutCopyMode = False
Selection.Copy
Columns("X:X").Select
ActiveSheet.Paste
Application.CutCopyMode = False

Range("AB2").FormulaR1C1 = _
"=IF(RC[-1]=""INITIALIZATION"",RC[3],IF(RC[-1]=""INSTRUCTION"",RC[5],IF(RC[-1]=""DEVELOPMENT"",RC[7],IF(RC[-1]=""OFFICIALIZATION - INDUSTRIALIZATION"",RC[9],RC[10]))))"
Range("AB2").AutoFill Destination:=Range("AB2:AB10000"), Type:=xlFillDefault
Columns("AB:AB").Copy
Columns("AB:AB").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("AB:AB").Select
Application.CutCopyMode = False

Rows("1:1").Select

ActiveWindow.LargeScroll ToRight:=2

Columns("A:N").Select
Range("N1").Delete Shift:=xlToLeft
Columns("B:B").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B2").FormulaR1C1 = "=IF(VALUE(RC[-1])=0,"""",VALUE(RC[-1]))"
Range("B2").AutoFill Destination:=Range("B2:B10000"), Type:=xlFillDefault
Columns("B:B").Copy
Columns("B:B").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Columns("A:A").Select
Range("A1").Delete Shift:=xlToLeft

ActiveWorkbook.Worksheets("vierge").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("vierge").AutoFilter.Sort.SortFields.Add Key:=Range _
("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("vierge").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Rows("1:1").AutoFilter
Columns("E:E").Copy
Columns("B:B").Paste
Columns("I:I").Select
Application.CutCopyMode = False
Selection.Copy
Columns("D

").Paste
Columns("F:F").Select
Application.CutCopyMode = False
Selection.Copy
Columns("C:C").Paste
Application.CutCopyMode = False
Columns("M:M").Select
Application.CutCopyMode = False
Selection.Copy
Columns("F:F").Paste
Application.CutCopyMode = False
Columns("N:N").Select
Application.CutCopyMode = False
Selection.Copy
Columns("G:G").Paste
Application.CutCopyMode = False
Columns("J:J").Select
Application.CutCopyMode = False
Selection.Copy
Columns("H:H").Paste
Application.CutCopyMode = False

' Simplification contenu vierge
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("vierge").Select
ActiveSheet.Range("$A$1:$O$10000").AutoFilter Field:=1, Criteria1:="<>"
Range("A1:O10000").Copy
Sheets("Feuil1").Range("A1").Paste
Application.CutCopyMode = False

Sheets("vierge").Delete
Sheets("Feuil1").Name = "vierge"

' Copie dans vierge des commentaires de la semaine précédente par reconnaissance du numéro de la FS
Range("E2").FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC[-4],'FS_semaine N'!R2C1:R1000C15,5,FALSE)),""NEW / à éclaircir"",VLOOKUP(RC[-4],'FS_semaine N'!R2C1:R1000C15,5,FALSE))"
Range("E2").AutoFill Destination:=Range("E2:E1000"), Type:=xlFillDefault
Columns("E:E").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

' Copie dans vierge du Type de Réseau par reconnaissance du numéro de FS
Range("I2").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC[-8],'FS_semaine N'!R2C1:R1000C11,9,FALSE)),""NEW / à classer"",VLOOKUP(RC[-8],'FS_semaine N'!R2C1:R1000C11,9,FALSE))"
Range("I2").Select
Selection.AutoFill Destination:=Range("I2:I1000"), Type:=xlFillDefault
Columns("I:I").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

' Copie dans vierge de la Date prochain Réseau par reconnaissance de FS
Range("J2").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC[-9],'FS_semaine N'!R2C1:R1000C11,10,FALSE)),""NEW / à programmer"",VLOOKUP(RC[-9],'FS_semaine N'!R2C1:R1000C11,10,FALSE))"
Range("J2").Select
Selection.AutoFill Destination:=Range("J2:J1000"), Type:=xlFillDefault
Columns("J:J").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

' Copie dans vierge du Nom Acheteur par reconnaissance de FS
Range("K2").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC[-10],'FS_semaine N'!R2C1:R1000C15,11,FALSE)),"""",VLOOKUP(RC[-10],'FS_semaine N'!R2C1:R1000C15,11,FALSE))"
Range("K2").Select
Selection.AutoFill Destination:=Range("K2:K1000"), Type:=xlFillDefault
Columns("K:K").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

' Copie des Filtres GCO etc par reconaissance de FS
Range("L2").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC[-11],'FS_semaine N'!R2C1:R1000C16,12,FALSE)),"""",VLOOKUP(RC[-11],'FS_semaine N'!R2C1:R1000C16,12,FALSE))"
Range("L2").Select
Selection.AutoFill Destination:=Range("L2:L1000"), Type:=xlFillDefault
Columns("L:L").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

' Copie Filtre PCM
Range("M2").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC[-12],'FS_semaine N'!R2C1:R1000C16,13,FALSE)),"""",VLOOKUP(RC[-12],'FS_semaine N'!R2C1:R1000C16,13,FALSE))"
Range("M2").Select
Selection.AutoFill Destination:=Range("M2:M1000"), Type:=xlFillDefault
Columns("M:M").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

' Copie Filtre New RCO
Range("N2").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC[-13],'FS_semaine N'!R2C1:R1000C16,14,FALSE)),"""",VLOOKUP(RC[-13],'FS_semaine N'!R2C1:R1000C16,14,FALSE))"
Range("N2").Select
Selection.AutoFill Destination:=Range("N2:N1000"), Type:=xlFillDefault
Columns("N:N").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

' Copie Filtre Transfert
Range("O2").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC[-14],'FS_semaine N'!R2C1:R1000C16,15,FALSE)),"""",VLOOKUP(RC[-14],'FS_semaine N'!R2C1:R1000C16,15,FALSE))"
Range("O2").Select
Selection.AutoFill Destination:=Range("O2:O1000"), Type:=xlFillDefault
Columns("O:O").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

' Identification dans Semaine N des FS absentes du nouvel export
Sheets("FS_semaine N").Select
Range("F2").Select

ActiveCell.FormulaR1C1 = _
"=IF(OR(ISBLANK(RC[-5]),ISERROR(VLOOKUP(RC[-5],vierge!R2C1:R1000C9,6,FALSE))),""soldé ou abandonné"",VLOOKUP(RC[-5],vierge!R2C1:R1000C9,6,FALSE))"
Range("G2").Select
ActiveCell.FormulaR1C1 = _
"=IF(OR(ISBLANK(RC[-6]),ISERROR(VLOOKUP(RC[-6],vierge!R2C1:R1000C9,7,FALSE))),""soldé ou abandonné"",VLOOKUP(RC[-6],vierge!R2C1:R1000C9,7,FALSE))"
Range("F2:G2").Select
Selection.AutoFill Destination:=Range("F2:G1000"), Type:=xlFillDefault
Range("F2:G1000").Select

Columns("F:F").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("G:G").Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Range("F2").Select
Sheets("vierge").Select
Columns("P:BJ").Select
Range("BJ1").Activate
Selection.Delete Shift:=xlToLeft
Range("O1").Select

' Application de Modèle sur onglet vierge
Sheets("Modèle").Select
Cells.Select
Selection.Copy
Sheets("vierge").Select
Cells.Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Sheets("Modèle").Select
Rows("1:1").Select
Selection.Copy
Sheets("vierge").Select
Rows("1:1").Select
ActiveSheet.Paste

' Décalage des onglets N-1 => N + création onglet vierge
Sheets("FS_semaine N-1").Select
Application.CutCopyMode = False
ActiveWindow.SelectedSheets.Delete
Sheets("FS_semaine N").Select
Sheets("FS_semaine N").Name = "FS_semaine N-1"
Rows("1:1").Select
Selection.AutoFilter
Sheets("vierge").Select
Sheets("vierge").Name = "FS_semaine N"
Sheets.Add After:=Sheets(Sheets.Count)
Sheets("Feuil2").Select
Sheets("Feuil2").Name = "vierge"
Sheets("FS_semaine N").Select
Rows("1:1").Select
Selection.AutoFilter

' Copie des Noms acheteur + GCO + PCM + J3J4 + UT par reconnaissance FS en N-1
Range("K2").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC[-10],'FS_semaine N-1'!R2C1:R1000C12,11,FALSE)),"""",VLOOKUP(RC[-10],'FS_semaine N-1'!R2C1:R1000C12,11,FALSE))"
Range("K2").Select
Selection.AutoFill Destination:=Range("K2:K1000"), Type:=xlFillDefault
Range("K2:K1000").Select

Columns("K:K").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Range("L2").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC[-11],'FS_semaine N-1'!R2C1:R1000C12,12,FALSE)),"""",VLOOKUP(RC[-11],'FS_semaine N-1'!R2C1:R1000C12,12,FALSE))"
Range("L2").Select
Selection.AutoFill Destination:=Range("L2:L1000"), Type:=xlFillDefault
Range("L2:L1000").Select

Columns("L:L").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Range("M2").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC[-12],'FS_semaine N-1'!R2C1:R1000C15,13,FALSE)),"""",VLOOKUP(RC[-12],'FS_semaine N-1'!R2C1:R1000C15,13,FALSE))"
Range("M2").Select
Selection.AutoFill Destination:=Range("M2:M1000"), Type:=xlFillDefault
Range("M2:M1000").Select

Columns("M:M").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Range("N2").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC[-13],'FS_semaine N-1'!R2C1:R1000C15,14,FALSE)),"""",VLOOKUP(RC[-13],'FS_semaine N-1'!R2C1:R1000C15,14,FALSE))"
Range("N2").Select
Selection.AutoFill Destination:=Range("N2:N1000"), Type:=xlFillDefault
Range("N2:N1000").Select

Columns("N:N").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

Range("O2").Select
ActiveCell.FormulaR1C1 = _
"=IF(ISERROR(VLOOKUP(RC[-14],'FS_semaine N-1'!R2C1:R1000C15,15,FALSE)),"""",VLOOKUP(RC[-14],'FS_semaine N-1'!R2C1:R1000C15,15,FALSE))"
Range("O2").Select
Selection.AutoFill Destination:=Range("O2:O1000"), Type:=xlFillDefault
Range("O2:O1000").Select

Columns("O:O").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

' Application Menus Déroulants sur Date Réseau RCO et Type Réseau
Range("J2:J1000").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:= _
"=Modèle!$J$2:$J$31"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
Range("I2:I1000").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=Modèle!$I$2:$I$6"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With

' Application Menus Déroulants sur Acheteur OCM New RCO Transfert
Range("K2:K1000").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=Modèle!$H$2:$H$110"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With

Range("M2:M1000").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=Modèle!$E$2:$E$8"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With

Range("N2:N1000").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="=Modèle!$D$2:$D$15"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With

' Mise en forme visuel Semaine N
Range("D2").Select
ActiveWindow.Zoom = 80
With ActiveWindow
.SplitColumn = 4
.SplitRow = 1
End With
ActiveWindow.SplitColumn = 0
ActiveWindow.SplitRow = 2
ActiveWindow.SplitRow = 1
ActiveWindow.FreezePanes = True
Range("E2").Select

' Mise à jour de l'onglet Accueil
Sheets("Accueil").Select

Range("M5").Select
ActiveCell.FormulaR1C1 = _
"=COUNTIF('FS_semaine N'!R1C10:R997C10,Accueil!R[-1]C)"
Range("M5").Select
Selection.Copy
Range("N5:S5").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("M7").Select
ActiveCell.FormulaR1C1 = _
"=COUNTIFS('FS_semaine N'!R1C10:R997C10,Accueil!R[-3]C,'FS_semaine N'!R1C3:R997C3,""PEPP DV"")"
Range("M7").Select
Selection.Copy
Range("N7:S7").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("M9").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = _
"=COUNTIFS('FS_semaine N'!R1C10:R997C10,Accueil!R[-5]C,'FS_semaine N'!R1C3:R997C3,""PEPP DW"")"
Range("M9").Select
Selection.Copy
Range("N9:S9").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("M11").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = _
"=COUNTIFS('FS_semaine N'!R1C10:R997C10,Accueil!R[-7]C,'FS_semaine N'!R1C3:R997C3,""PEPP VSUD Transversal"")"
Range("M11").Select
Selection.Copy
Range("N11:S11").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("M13").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = _
"=COUNTIFS('FS_semaine N'!R3C10:R999C10,Accueil!R[-9]C,'FS_semaine N'!R3C3:R999C3,""PEPP DT-PUMA"")"
Range("M13").Select
Selection.Copy
Range("N13:S13").Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWindow.LargeScroll Down:=-1
Range("M5").Select

End Sub

AtTheOne · 28 Mars 2023

Bonjour à toutes & à tous,
bonjour @SAAD doli
Pourrais-tu joindre un fichier avec la structure de ton classeur et quelques donnée factices ?
Ça serait plus facile pour nous
Quelle version d'EXCEL ? Autre ???
Ligne du plantage ?

SAAD doli · 28 Mars 2023

AtTheOne à dit:
Bonjour à toutes & à tous,
bonjour @SAAD doli
Pourrais-tu joindre un fichier avec la structure de ton classeur et quelques donnée factices ?
Ça serait plus facile pour nous
Quelle version d'EXCEL ? Autre ???
Ligne du plantage ?

Bnj @AtTheOne
voici le dossier je suis censé modifier ces macros et les rendre plus rapides
j'ai commencé à apprendre vba cette semaine ,pour cela j'ai rejoint ce forum
merci de me proposer des modifs pour optimiser le code
pour la ligne de plantage , c'est bon j'ai fixé cette erreur

merci pour votre réponse

AtTheOne · 28 Mars 2023

Re-bonjour,
Sans la structure de ton classeur ni l'objectif de la macro, pas facile de t'aider ...

Edit : Pas de pièce jointe ???

SAAD doli · 28 Mars 2023

Hi
voici le dossier
il s'agit d'un dossier qui contient les informations concernant des ECR : des solutions à des issues , le rôle de ces macros est de faire la mise à jour de ces données .
dans la page vierge on colle les données depuis un logiciel et on lance ces macros pour avoir les données dont on a besoin , d'une façon structurée et plus pertinente (on supprime quelques lignes et on mis à jour les autres )Enfin on les stocks dans la feuille semaine N , on nomme la semaine N par Semaine N-1 et vierge par semaine N , l'onglet accueil permet de calculer les sujets qu'on pour cette semaine
la macro 5 : contient des filtres qu'on applique sur ces sujets
la macro 19 : la macro qui gère les données depuis LOGI_1
la macro 12 :la macro qui gère les données depuis LOGI_2

je sais pas si je peux partager les données parce que c'est confidentiel

AtTheOne · 28 Mars 2023

re

SAAD doli à dit:
je sais pas si je peux partager les données parce que c'est confidentiel

Non, tu ne peux pas, mais tu peux écrire quelques lignes factices ...

AtTheOne · 28 Mars 2023

re, re
Ne peut-on pas identifier la dernière ligne de ton import (par exemple dernière cellule non vide de la colonne A) ? Cela éviterrait d'écrire des formules sur 10000 lignes dont la plus grande partie est inutile.

AtTheOne · 29 Mars 2023

Bonne nuit à toutes & à tous,
bonne nuit @SAAD doli

Voilà comment j'ai transformé ta macro de post#1, Mais sans données à traiter difficile de déboguer et d'optimiser. Essai la pièce jointe (module mdl_AtTheOne macro Sub MàJ_Semaine)
Question : à quoi sert de manipuler les colonnes au delà de la colonne O ?

VB:

Sub MàJ_Semaine()
     'Prépare la feuille "Vierge" contenant les données importées
     'Transfert "Semaine N" vers "Semaine N-1" et "Vierge" modifiée vers "Semaine N"
     'Rétablit les formules de synthèse de la feuille Accueil

     Dim Sh_SN1 As Worksheet 'Semaine N
     Dim Sh_SN0 As Worksheet 'Semaine N-1
     Dim Sh_V As Worksheet   'Vierge
     Dim Sh_N As Worksheet   'Nouvelle feuille
   
     Dim NbLgn As Long, LFin As Long, NbLBis As Long, rg As Range
     Application.ScreenUpdating = False
   
     With ThisWorkbook
          Set Sh_SN1 = .Worksheets("Fs_semaine N")
          Set Sh_V = .Worksheets("vierge")
     End With
     If Sh_SN1.FilterMode Then Sh_SN1.ShowAllData
   
     'Actions sur la feuille "Vierge"
     With Sh_V
          .[A:CJ].EntireColumn.Hidden = False
          .[1:7].Delete Shift:=xlUp
          With .Cells
               .WrapText = True
               .Orientation = 0
               .AddIndent = False
               .ShrinkToFit = False
               .ReadingOrder = xlContext
               .MergeCells = False
          End With
         
          NbLgn = .Cells(.Rows.Count, 1).End(xlUp).Row - 1 '(nombre de lignes de données de "Vierge" : Exclut ligne de titre)
          If NbLgn < 1 Then
               MsgBox "Pas de données dans la feuille ""Vierge""" & Chr(13) & _
                       "Remplir l'onglet ""Vierge"" avec les données des fichiers score (onglet exportsingle)"
               Exit Sub 'Sortir s'il n"y a pas de données dans la feuille "Vierge"
          End If
         
          Set rg = .[Y2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IF(ISBLANK(R[1]C[-10]),CONCATENATE(RC[-1],"" "",R[1]C[-1]),RC[-1])"
          rg.Value = rg.Value
          rg.Copy Destination:=.[X1].Resize(NbLgn)
         
          Set rg = .[AB2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IF(RC[-1]=""INITIALIZATION"",RC[3],IF(RC[-1]=""INSTRUCTION"",RC[5],IF(RC[-1]=""DEVELOPMENT"",RC[7],IF(RC[-1]=""OFFICIALIZATION - INDUSTRIALIZATION"",RC[9],RC[10]))))"
          rg.Value = rg.Value
         
          .[N1].Delete Shift:=xlToLeft   'Pourquoi ???
          .[B:B].Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
         
          Set rg = .[B2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IF(VALUE(RC[-1])=0,"""",VALUE(RC[-1]))"
          rg.Value = rg.Value
         
          .[A1].Delete Shift:=xlToLeft   'Pourquoi ???
         
          If .AutoFilterMode Then .Cells.AutoFilter
          .[1:1].AutoFilter
          With .AutoFilter.Sort
               .SortFields.Clear
               .SortFields.Add Key:=[A1], SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
               .Header = xlYes
               .MatchCase = False
               .Orientation = xlTopToBottom
               .SortMethod = xlPinYin
               .Apply
          End With
          NbLgn = NbLgn + 1 '(Nbre de lignes à copier de "Vierge" : Inclut ligne de titre)
          .[E1].Resize(NbLgn).Copy Destination:=.[B1].Resize(NbLgn)
          .[I1].Resize(NbLgn).Copy Destination:=.[D1].Resize(NbLgn)
          .[F1].Resize(NbLgn).Copy Destination:=.[C1].Resize(NbLgn)
          .[M1].Resize(NbLgn).Copy Destination:=.[F1].Resize(NbLgn)
          .[N1].Resize(NbLgn).Copy Destination:=.[G1].Resize(NbLgn)
          .[J1].Resize(NbLgn).Copy Destination:=.[H1].Resize(NbLgn)
     End With
   
     With ThisWorkbook
          .Worksheets.Add after:=.Worksheets(.Worksheets.Count)
          Set Sh_N = ActiveSheet
     End With
     With Sh_V.[A1:O1].Resize(NbLgn + 1)
          .AutoFilter Field:=1, Criteria1:="<>"
          .Copy Destination:=Sh_N.[A1]
     End With
     Application.DisplayAlerts = False: Sh_V.Delete: Application.DisplayAlerts = True
     Set Sh_V = Nothing
     Sh_N.Name = "Vierge"
     Set Sh_V = Sh_N
     Set Sh_N = Nothing
   
     With Sh_V
          NbLgn = .Cells(.Rows.Count, 1).End(xlUp).Row - 1 '(Nombre de lignes à renseigner de "Vierge")
          LFin = Sh_SN1.Cells(.Rows.Count, 1).End(xlUp).Row  '(Dernière ligne renseignée de "Semaine N")
         
          ' Copie dans vierge des commentaires de la semaine précédente par reconnaissance du numéro de la FS
          Set rg = .[E2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-4],'FS_semaine N'!R2C1:R" & LFin & "C15,5,FALSE),""NEW / à éclaircir"")"
          rg.Value = rg.Value
         
          ' Copie dans vierge du Type de Réseau par reconnaissance du numéro de FS
          Set rg = .[I2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-8],'FS_semaine N'!R2C1:R" & LFin & "C11,9,FALSE),""NEW / à classer"")"
          rg.Value = rg.Value
         
          ' Copie dans vierge de la Date prochain Réseau par reconnaissance de FS
          Set rg = .[J2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-9],'FS_semaine N'!R2C1:R" & LFin & "C11,10,FALSE),""NEW / à programmer"")"
          rg.Value = rg.Value
         
          ' Copie dans vierge du Nom Acheteur par reconnaissance de FS
          Set rg = .[K2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-10],'FS_semaine N'!R2C1:R" & LFin & "C15,11,FALSE),"""")"
          rg.Value = rg.Value

          ' Copie des Filtres GCO etc par reconaissance de FS
          Set rg = .[L2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-10],'FS_semaine N'!R2C1:R" & LFin & "C15,11,FALSE),"""")"
          rg.Value = rg.Value
         
          ' Copie Filtre PCM
          Set rg = .[M2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-12],'FS_semaine N'!R2C1:R" & LFin & "C16,13,FALSE),"""")"
          rg.Value = rg.Value
   
          ' Copie Filtre New RCO
          Set rg = .[N2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-13],'FS_semaine N'!R2C1:R" & LFin & "C16,14,FALSE),"""")"
          rg.Value = rg.Value
   
          ' Copie Filtre Transfert
          Set rg = .[O2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-14],'FS_semaine N'!R2C1:R" & LFin & "C16,15,FALSE),"""")"
          rg.Value = rg.Value
   
     End With
   
     With Sh_SN1
          NbLBis = LFin - 1 '(Nb lignes à renseigner dans "Semaine N")
          LFin = NbLgn + 1  '(Dernière ligne renseignée de "Vierge")
          ' Identification dans Semaine N des FS absentes du nouvel export
          Set rg = .[F2].Resize(NbLBis)
          rg.FormulaR1C1 = "=IF(ISBLANK(RC[-5]),""soldé ou abandonné"",IFERROR(VLOOKUP(RC[-5],vierge!R2C1:R" & LFin & "C9,6,FALSE),""soldé ou abandonné""))"
          rg.Value = rg.Value
         
          Set rg = .[G2].Resize(NbLBis)
          rg.FormulaR1C1 = "=IF(ISBLANK(RC[-6]),""soldé ou abandonné"",IFERROR(VLOOKUP(RC[-6],vierge!R2C1:R" & LFin & "9,7,FALSE),""soldé ou abandonné""))"
          rg.Value = rg.Value

     End With
   
     ' Application de Modèle sur onglet vierge
     With ThisWorkbook.Worksheets("Modèle")
          .[A1:O1].Copy Destination:=Sh_V.[A1:O1]
          .[A1:O1].Copy
          Sh_V.[A1:O1].PasteSpecial Paste:=xlPasteColumnWidths
          .[A2:O2].Copy
          Sh_V.[A2:O2].Resize(LFin - 1).PasteSpecial Paste:=xlPasteFormats
      End With
     
     ' Décalage des onglets N-1 => N + création onglet vierge
     ThisWorkbook.Worksheets("FS_semaine N-1").Delete
   
     With Sh_SN1
          .Name = "FS_semaine N-1"
          If Not .AutoFilterMode Then .Rows(1).AutoFilter
     End With
     Set Sh_SN0 = Sh_SN1
   
     With Sh_V
          .Name = "FS_semaine N"
          If Not .AutoFilterMode Then .Rows(1).AutoFilter
     End With
     Set Sh_SN1 = Sh_V
   
     With ThisWorkbook: .Worksheets.Add after:=.Worksheets(.Worksheets.Count): End With
     Set Sh_V = ActiveSheet
     Sh_V.Name = "Vierge"
   
     With Sh_SN1: NbLgn = .Cells(.Rows.Count, 1).End(xlUp).Row - 1: End With  'nbre de lignes à renseigner dans Semaine N
     With Sh_SN0: LFin = .Cells(.Rows.Count, 1).End(xlUp).Row: End With      'dernière ligne dans Semaine N-1
   
     With Sh_SN1
     ' Copie des Noms acheteur + GCO + PCM + J3J4 + UT par reconnaissance FS en N-1
          Set rg = .[K2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-10],'FS_semaine N-1'!R2C1:R" & LFin & "C12,11,FALSE),"""")"
          rg.Value = rg.Value

          Set rg = .[L2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-11],'FS_semaine N-1'!R2C1:R" & LFin & "C12,12,FALSE),"""")"
          rg.Value = rg.Value

          Set rg = .[M2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-12],'FS_semaine N-1'!R2C1:R" & LFin & "C15,13,FALSE),"""")"
          rg.Value = rg.Value

          Set rg = .[N2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-13],'FS_semaine N-1'!R2C1:R" & LFin & "C15,14,FALSE),"""")"
          rg.Value = rg.Value

          Set rg = .[O2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-14],'FS_semaine N-1'!R2C1:R" & LFin & "C15,15,FALSE),"""")"
          rg.Value = rg.Value

     ' Application Menus Déroulants sur Acheteur OCM New RCO Transfert
          Set rg = .[K2].Resize(NbLgn)
          With rg.Validation
               .Delete
               .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="=Modèle!$H$2:$H$110"
               .InCellDropdown = True
               .ShowInput = True
               .ShowError = True
          End With
          Set rg = .[M2].Resize(NbLgn)
          With rg.Validation
               .Delete
               .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="=Modèle!$E$2:$E$8"
               .InCellDropdown = True
               .ShowInput = True
               .ShowError = True
          End With
          Set rg = .[N2].Resize(NbLgn)
          With rg.Validation
               .Delete
               .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="=Modèle!$D$2:$D$15"
               .InCellDropdown = True
               .ShowInput = True
               .ShowError = True
          End With
     
       ' Zoom et volets figer en D2
          .Activate
          ActiveWindow.Zoom = 80
          .[D2].Activate
          ActiveWindow.FreezePanes = True
     End With
   
     LFin = NbLgn - 1
     With ThisWorkbook.Worksheets("Accueil")
          .[M5:S5].FormulaR1C1 = "=COUNTIF('FS_semaine N'!R2C10:R" & LFin & "C10,Accueil!R[-1]C)"
          .[M7:S7].FormulaR1C1 = "=COUNTIFS('FS_semaine N'!R2C10:R" & LFin & "C10,Accueil!R[-3]C,'FS_semaine N'!R2C3:R" & LFin & "C3,""PEPP DV"")"
          .[M9:S9].FormulaR1C1 = "=COUNTIFS('FS_semaine N'!R2C10:R" & LFin & "C10,Accueil!R[-5]C,'FS_semaine N'!R2C3:R" & LFin & "C3,""PEPP DW"")"
          .[M11:S11].FormulaR1C1 = "=COUNTIFS('FS_semaine N'!R2C10:R" & LFin & "C10,Accueil!R[-7]C,'FS_semaine N'!R2C3:R" & LFin & "C3,""PEPP VSUD Transversal"")"
          .[M13:S13].FormulaR1C1 = "=COUNTIFS('FS_semaine N'!R2C10:R" & LFin & "C10,Accueil!R[-9]C,'FS_semaine N'!R2C3:R" & LFin & "C3,""PEPP DT-PUMA"")"
     End With
   
End Sub

Si tu pouvais créer un jeu de données factices cela aiderait à la compréhension et au débogage ...

Bon courage

SAAD doli · 29 Mars 2023

AtTheOne à dit:

Bonne nuit à toutes & à tous,
bonne nuit @SAAD doli

Voilà comment j'ai transformé ta macro de post#1, Mais sans données à traiter difficile de déboguer et d'optimiser. Essai la pièce jointe (module mdl_AtTheOne macro Sub MàJ_Semaine)
Question : à quoi sert de manipuler les colonnes au delà de la colonne O ?

VB:

Sub MàJ_Semaine()
     'Prépare la feuille "Vierge" contenant les données importées
     'Transfert "Semaine N" vers "Semaine N-1" et "Vierge" modifiée vers "Semaine N"
     'Rétablit les formules de synthèse de la feuille Accueil

     Dim Sh_SN1 As Worksheet 'Semaine N
     Dim Sh_SN0 As Worksheet 'Semaine N-1
     Dim Sh_V As Worksheet   'Vierge
     Dim Sh_N As Worksheet   'Nouvelle feuille
  
     Dim NbLgn As Long, LFin As Long, NbLBis As Long, rg As Range
     Application.ScreenUpdating = False
  
     With ThisWorkbook
          Set Sh_SN1 = .Worksheets("Fs_semaine N")
          Set Sh_V = .Worksheets("vierge")
     End With
     If Sh_SN1.FilterMode Then Sh_SN1.ShowAllData
  
     'Actions sur la feuille "Vierge"
     With Sh_V
          .[A:CJ].EntireColumn.Hidden = False
          .[1:7].Delete Shift:=xlUp
          With .Cells
               .WrapText = True
               .Orientation = 0
               .AddIndent = False
               .ShrinkToFit = False
               .ReadingOrder = xlContext
               .MergeCells = False
          End With
        
          NbLgn = .Cells(.Rows.Count, 1).End(xlUp).Row - 1 '(nombre de lignes de données de "Vierge" : Exclut ligne de titre)
          If NbLgn < 1 Then
               MsgBox "Pas de données dans la feuille ""Vierge""" & Chr(13) & _
                       "Remplir l'onglet ""Vierge"" avec les données des fichiers score (onglet exportsingle)"
               Exit Sub 'Sortir s'il n"y a pas de données dans la feuille "Vierge"
          End If
        
          Set rg = .[Y2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IF(ISBLANK(R[1]C[-10]),CONCATENATE(RC[-1],"" "",R[1]C[-1]),RC[-1])"
          rg.Value = rg.Value
          rg.Copy Destination:=.[X1].Resize(NbLgn)
        
          Set rg = .[AB2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IF(RC[-1]=""INITIALIZATION"",RC[3],IF(RC[-1]=""INSTRUCTION"",RC[5],IF(RC[-1]=""DEVELOPMENT"",RC[7],IF(RC[-1]=""OFFICIALIZATION - INDUSTRIALIZATION"",RC[9],RC[10]))))"
          rg.Value = rg.Value
        
          .[N1].Delete Shift:=xlToLeft   'Pourquoi ???
          .[B:B].Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        
          Set rg = .[B2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IF(VALUE(RC[-1])=0,"""",VALUE(RC[-1]))"
          rg.Value = rg.Value
        
          .[A1].Delete Shift:=xlToLeft   'Pourquoi ???
        
          If .AutoFilterMode Then .Cells.AutoFilter
          .[1:1].AutoFilter
          With .AutoFilter.Sort
               .SortFields.Clear
               .SortFields.Add Key:=[A1], SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
               .Header = xlYes
               .MatchCase = False
               .Orientation = xlTopToBottom
               .SortMethod = xlPinYin
               .Apply
          End With
          NbLgn = NbLgn + 1 '(Nbre de lignes à copier de "Vierge" : Inclut ligne de titre)
          .[E1].Resize(NbLgn).Copy Destination:=.[B1].Resize(NbLgn)
          .[I1].Resize(NbLgn).Copy Destination:=.[D1].Resize(NbLgn)
          .[F1].Resize(NbLgn).Copy Destination:=.[C1].Resize(NbLgn)
          .[M1].Resize(NbLgn).Copy Destination:=.[F1].Resize(NbLgn)
          .[N1].Resize(NbLgn).Copy Destination:=.[G1].Resize(NbLgn)
          .[J1].Resize(NbLgn).Copy Destination:=.[H1].Resize(NbLgn)
     End With
  
     With ThisWorkbook
          .Worksheets.Add after:=.Worksheets(.Worksheets.Count)
          Set Sh_N = ActiveSheet
     End With
     With Sh_V.[A1:O1].Resize(NbLgn + 1)
          .AutoFilter Field:=1, Criteria1:="<>"
          .Copy Destination:=Sh_N.[A1]
     End With
     Application.DisplayAlerts = False: Sh_V.Delete: Application.DisplayAlerts = True
     Set Sh_V = Nothing
     Sh_N.Name = "Vierge"
     Set Sh_V = Sh_N
     Set Sh_N = Nothing
  
     With Sh_V
          NbLgn = .Cells(.Rows.Count, 1).End(xlUp).Row - 1 '(Nombre de lignes à renseigner de "Vierge")
          LFin = Sh_SN1.Cells(.Rows.Count, 1).End(xlUp).Row  '(Dernière ligne renseignée de "Semaine N")
        
          ' Copie dans vierge des commentaires de la semaine précédente par reconnaissance du numéro de la FS
          Set rg = .[E2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-4],'FS_semaine N'!R2C1:R" & LFin & "C15,5,FALSE),""NEW / à éclaircir"")"
          rg.Value = rg.Value
        
          ' Copie dans vierge du Type de Réseau par reconnaissance du numéro de FS
          Set rg = .[I2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-8],'FS_semaine N'!R2C1:R" & LFin & "C11,9,FALSE),""NEW / à classer"")"
          rg.Value = rg.Value
        
          ' Copie dans vierge de la Date prochain Réseau par reconnaissance de FS
          Set rg = .[J2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-9],'FS_semaine N'!R2C1:R" & LFin & "C11,10,FALSE),""NEW / à programmer"")"
          rg.Value = rg.Value
        
          ' Copie dans vierge du Nom Acheteur par reconnaissance de FS
          Set rg = .[K2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-10],'FS_semaine N'!R2C1:R" & LFin & "C15,11,FALSE),"""")"
          rg.Value = rg.Value

          ' Copie des Filtres GCO etc par reconaissance de FS
          Set rg = .[L2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-10],'FS_semaine N'!R2C1:R" & LFin & "C15,11,FALSE),"""")"
          rg.Value = rg.Value
        
          ' Copie Filtre PCM
          Set rg = .[M2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-12],'FS_semaine N'!R2C1:R" & LFin & "C16,13,FALSE),"""")"
          rg.Value = rg.Value
  
          ' Copie Filtre New RCO
          Set rg = .[N2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-13],'FS_semaine N'!R2C1:R" & LFin & "C16,14,FALSE),"""")"
          rg.Value = rg.Value
  
          ' Copie Filtre Transfert
          Set rg = .[O2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-14],'FS_semaine N'!R2C1:R" & LFin & "C16,15,FALSE),"""")"
          rg.Value = rg.Value
  
     End With
  
     With Sh_SN1
          NbLBis = LFin - 1 '(Nb lignes à renseigner dans "Semaine N")
          LFin = NbLgn + 1  '(Dernière ligne renseignée de "Vierge")
          ' Identification dans Semaine N des FS absentes du nouvel export
          Set rg = .[F2].Resize(NbLBis)
          rg.FormulaR1C1 = "=IF(ISBLANK(RC[-5]),""soldé ou abandonné"",IFERROR(VLOOKUP(RC[-5],vierge!R2C1:R" & LFin & "C9,6,FALSE),""soldé ou abandonné""))"
          rg.Value = rg.Value
        
          Set rg = .[G2].Resize(NbLBis)
          rg.FormulaR1C1 = "=IF(ISBLANK(RC[-6]),""soldé ou abandonné"",IFERROR(VLOOKUP(RC[-6],vierge!R2C1:R" & LFin & "9,7,FALSE),""soldé ou abandonné""))"
          rg.Value = rg.Value

     End With
  
     ' Application de Modèle sur onglet vierge
     With ThisWorkbook.Worksheets("Modèle")
          .[A1:O1].Copy Destination:=Sh_V.[A1:O1]
          .[A1:O1].Copy
          Sh_V.[A1:O1].PasteSpecial Paste:=xlPasteColumnWidths
          .[A2:O2].Copy
          Sh_V.[A2:O2].Resize(LFin - 1).PasteSpecial Paste:=xlPasteFormats
      End With
    
     ' Décalage des onglets N-1 => N + création onglet vierge
     ThisWorkbook.Worksheets("FS_semaine N-1").Delete
  
     With Sh_SN1
          .Name = "FS_semaine N-1"
          If Not .AutoFilterMode Then .Rows(1).AutoFilter
     End With
     Set Sh_SN0 = Sh_SN1
  
     With Sh_V
          .Name = "FS_semaine N"
          If Not .AutoFilterMode Then .Rows(1).AutoFilter
     End With
     Set Sh_SN1 = Sh_V
  
     With ThisWorkbook: .Worksheets.Add after:=.Worksheets(.Worksheets.Count): End With
     Set Sh_V = ActiveSheet
     Sh_V.Name = "Vierge"
  
     With Sh_SN1: NbLgn = .Cells(.Rows.Count, 1).End(xlUp).Row - 1: End With  'nbre de lignes à renseigner dans Semaine N
     With Sh_SN0: LFin = .Cells(.Rows.Count, 1).End(xlUp).Row: End With      'dernière ligne dans Semaine N-1
  
     With Sh_SN1
     ' Copie des Noms acheteur + GCO + PCM + J3J4 + UT par reconnaissance FS en N-1
          Set rg = .[K2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-10],'FS_semaine N-1'!R2C1:R" & LFin & "C12,11,FALSE),"""")"
          rg.Value = rg.Value

          Set rg = .[L2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-11],'FS_semaine N-1'!R2C1:R" & LFin & "C12,12,FALSE),"""")"
          rg.Value = rg.Value

          Set rg = .[M2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-12],'FS_semaine N-1'!R2C1:R" & LFin & "C15,13,FALSE),"""")"
          rg.Value = rg.Value

          Set rg = .[N2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-13],'FS_semaine N-1'!R2C1:R" & LFin & "C15,14,FALSE),"""")"
          rg.Value = rg.Value

          Set rg = .[O2].Resize(NbLgn)
          rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-14],'FS_semaine N-1'!R2C1:R" & LFin & "C15,15,FALSE),"""")"
          rg.Value = rg.Value

     ' Application Menus Déroulants sur Acheteur OCM New RCO Transfert
          Set rg = .[K2].Resize(NbLgn)
          With rg.Validation
               .Delete
               .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="=Modèle!$H$2:$H$110"
               .InCellDropdown = True
               .ShowInput = True
               .ShowError = True
          End With
          Set rg = .[M2].Resize(NbLgn)
          With rg.Validation
               .Delete
               .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="=Modèle!$E$2:$E$8"
               .InCellDropdown = True
               .ShowInput = True
               .ShowError = True
          End With
          Set rg = .[N2].Resize(NbLgn)
          With rg.Validation
               .Delete
               .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="=Modèle!$D$2:$D$15"
               .InCellDropdown = True
               .ShowInput = True
               .ShowError = True
          End With
    
       ' Zoom et volets figer en D2
          .Activate
          ActiveWindow.Zoom = 80
          .[D2].Activate
          ActiveWindow.FreezePanes = True
     End With
  
     LFin = NbLgn - 1
     With ThisWorkbook.Worksheets("Accueil")
          .[M5:S5].FormulaR1C1 = "=COUNTIF('FS_semaine N'!R2C10:R" & LFin & "C10,Accueil!R[-1]C)"
          .[M7:S7].FormulaR1C1 = "=COUNTIFS('FS_semaine N'!R2C10:R" & LFin & "C10,Accueil!R[-3]C,'FS_semaine N'!R2C3:R" & LFin & "C3,""PEPP DV"")"
          .[M9:S9].FormulaR1C1 = "=COUNTIFS('FS_semaine N'!R2C10:R" & LFin & "C10,Accueil!R[-5]C,'FS_semaine N'!R2C3:R" & LFin & "C3,""PEPP DW"")"
          .[M11:S11].FormulaR1C1 = "=COUNTIFS('FS_semaine N'!R2C10:R" & LFin & "C10,Accueil!R[-7]C,'FS_semaine N'!R2C3:R" & LFin & "C3,""PEPP VSUD Transversal"")"
          .[M13:S13].FormulaR1C1 = "=COUNTIFS('FS_semaine N'!R2C10:R" & LFin & "C10,Accueil!R[-9]C,'FS_semaine N'!R2C3:R" & LFin & "C3,""PEPP DT-PUMA"")"
     End With
  
End Sub

Si tu pouvais créer un jeu de données factices cela aiderait à la compréhension et au débogage ...

Bon courage

Bonjour @AtTheOne , j'espère que vous allez bien
j'ai généré des données factices et j'ai ajouté des commentaires pour que tu puisse comprendre les macros
Vous trouvez aussi le dossier d'export qu'on utilise dans la feuille vierge pour les manipulations
MACRO module 19 : fait les manipulation sur la feuille vierge qui contient l'import PLM
MACRO module 12 : fait les manipulation sur la feuille vierge qui contient l'import ALTIS
merci

SAAD doli · 29 Mars 2023

SAAD doli à dit:
Bonjour @AtTheOne , j'espère que vous allez bien
j'ai généré des données factices et j'ai ajouté des commentaires pour que tu puisse comprendre les macros
Vous trouvez aussi le dossier d'export qu'on utilise dans la feuille vierge pour les manipulations
MACRO module 19 : fait les manipulation sur la feuille vierge qui contient l'import PLM
MACRO module 12 : fait les manipulation sur la feuille vierge qui contient l'import ALTIS
merci

AtTheOne · 29 Mars 2023

Bonjour,
Ta macro du module 19 (Extract_PML) a bien changé par rapport à celle de ton post#1 sur laquelle j'avais travaillé ... n fois sur le métier remettez votre ouvrage ...
Bon je me replonge la dessus.

AtTheOne · 30 Mars 2023

Bonjour à toutes & à tous,
bonjour @SAAD doli
Dans tes exemples d'extraction PML et ALTIS, la fin des données est difficile à distinguer.
Y a-t-il une colonne avec laquelle se repérer en en cherchant la dernière cellule ? Sinon, je prends la plage occupée (USEDRANGE) pour ne pas traîner des formules sur 10000 lignes inutilement.

De même dans les onglets semaine N et semaine N-1, je vais utiliser des tableaux structurés qui étendront automatiquement les formats et les validations de données. Or le bas de la feuille est un peu flou, peut-on se baser sur la colonne A ou F (comme tu l'as fait) pour repérer la fin de la liste.

J'ai traité l'import PML, pour ALTIS ça ressemble à ce que j'ai fait précédemment, mais je vais passer par des tableau VB, pour accélérer le traitement.
Je ne suis pas disponible cet après-midi,
Je m'y remets ce soir.

AtTheOne · 30 Mars 2023

Re,
Dans ton exemple d'extraction ALTIS il y a des cellules fusionnées, faut-il remplir toutes les lignes de ces plages fusionnées avec la valeur affichée ?
En particulier pour les colonnes S et T que l'on retrouve en colonne B et C après traitement.

De plus je ne comprends pas bien la mécanique dans la colonne Y pour remplir la colonne X (col H après traitement) à partir de la colonne O : "=IF(ISBLANK(R[1]C[-10]),CONCATENATE(RC[-1],"" "",R[1]C[-1]),RC[-1])"
Si la colonne O est vide, on concatène X, un espace et la valeur X de la ligne du dessous, sinon on prend la valeur de X.
Est-bien cela ? car ce n'est pas conforme à ton commentaire :

'verifier si O3 est vide sinon concaténer "X3 Z3"-> X3

(Ton tableau n'est pas trié au moment ou la macro fait cela)
Merci de me répondre, ça a une influence sur ce que je veux faire...

AtTheOne · 31 Mars 2023

Bonne nuit,
Voilà ou j'en suis :

J'ai un peu épuré des données factices (arrêt de toutes les colonnes à une même ligne).
Faute de mieux je me suis référé à la plage occupée par tes données des extracts.
J'ai pris le parti de compléter les plage fusionnée avec la valeur de la première cellule de ces plages, mais il y a une imprécision s'il y a des plages fusionnées vides (elles récupéreront la valeur du dessus).
J'ai ajouter un onglet "Tables" pour placer toutes les listes qui se trouvaient dans le modèle dans des tableaux structurés.
J'ai créé des tableaux structurés "tb_SN_1" et "tb_SN"pour contenir les données de tes onglets "FS_semaine N-1" et "FS_semaine N".
Cela permet d'étendre automatiquement les formules (il n'y en a pas), les formats et les validations de données. avec un style personnalisé "Style_Semaine" (uniquement le quadrillage, mais tu peux améliorer). Du coup l'onglet Modèle n'a plus lieu d'exister.
J'ai écrit les macros "Traiter_Extract_PML" et "Traiter_Extract_ALTIS" volontairement de deux façons différentes. la première en manipulant directement les objets EXCEL, la seconde en passant par des tableaux VB et en plaquant ensuite les résultats dans les tableaux structurés (en fin ou en remplacement les anciennes valeurs)

Il faut que tu répondes à mes questions du post précédent :

AtTheOne à dit:
Dans ton exemple d'extraction ALTIS il y a des cellules fusionnées, faut-il remplir toutes les lignes de ces plages fusionnées avec la valeur affichée ?
En particulier pour les colonnes S et T que l'on retrouve en colonne B et C après traitement.

AtTheOne à dit:
De plus je ne comprends pas bien la mécanique dans la colonne Y pour remplir la colonne X (col H après traitement) à partir de la colonne O : "=IF(ISBLANK(R[1]C[-10]),CONCATENATE(RC[-1],"" "",R[1]C[-1]),RC[-1])"
Si la colonne O est vide, on concatène X, un espace et la valeur X de la ligne du dessous, sinon on prend la valeur de X.
Est-bien cela ? car ce n'est pas conforme à ton commentaire :
'verifier si O3 est vide sinon concaténer "X3 Z3"-> X3

Voilà le texte des deux macros.
Traiter_Extract_PML

VB:

Sub Traiter_Extract_PML()
     Const ColF = 6, ColO = 15
   
     Dim Sh_PML As Worksheet, Sh_SN As Worksheet, LO As ListObject
     Dim Rg As Range, FinPML As Long, NbPML As Long
   
     With ThisWorkbook
          Set Sh_PML = .Worksheets("Vierge")
          Set Sh_SN = .Worksheets("FS_semaine N")
     End With
   
     With Sh_PML
     'Pas de lignes filtrées
          If .FilterMode Then .ShowAllData
          .AutoFilterMode = False
    'Suppr lignes d'entêtes
          .[1:6].Delete Shift:=xlUp

    'Réordonnancement des colonnes
          .[BO:PK].Delete Shift = xlToLeft
          .[AK:BM].Delete Shift = xlToLeft
          .[Q:AI].Delete Shift = xlToLeft
          .[P:P].Cut: .[E:E].Insert Shift:=xlToRight
          .[I:P].Delete Shift = xlToLeft
          .[H:H].Cut: .[F:F].Insert Shift:=xlToRight
          .[A:B].Delete Shift = xlToLeft
   
     'Lignes utiles
          FinPML = .Cells(.Rows.Count, 1).End(xlUp).Row
          NbPML = FinPML - 1
     'Sortir s'il n"y a pas de données dans la feuille "Vierge"
          If NbPML < 1 Then
               MsgBox "Pas de données dans l'Import PML" & Chr(13) & _
                       "Remplir l'onglet ""Vierge"" avec les données des fichiers score (onglet exportsingle)"
               Exit Sub
          End If
   
     ' Copie des constats : Copie dans vierge des commentaires de la semaine précédente par reconnaissance du numéro ECR
          Set Rg = .[E2].Resize(NbPML)
          Rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-4],'FS_semaine N'!R2C1:R" & LFin & "C15,5,FALSE),""NEW / à éclaircir"")"
          Rg.Value = Rg.Value
     ' Copie dans vierge du Type de Réseau par reconnaissance du numéro de FS
          Set Rg = .[I2].Resize(NbPML)
          Rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-8],'FS_semaine N'!R2C1:R" & LFin & "C15,9,FALSE),""NEW / à classer"")"
          Rg.Value = Rg.Value
     ' Copie dans vierge de la Date prochain Réseau par reconnaissance de FS
          Set Rg = .[J2].Resize(NbPML)
          Rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-9],'FS_semaine N'!R2C1:R" & LFin & "C15,10,FALSE),""NEW / à programmer"")"
          Rg.Value = Rg.Value
     ' Copie dans vierge du Nom Acheteur par reconnaissance de FS
          Set Rg = .[K2].Resize(NbPML)
          Rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-10],'FS_semaine N'!R2C1:R" & LFin & "C15,11,FALSE),"""")"
          Rg.Value = Rg.Value
     ' Copie des Filtres GCO etc par reconaissance de FS
          Set Rg = .[L2].Resize(NbPML)
          Rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-11],'FS_semaine N-1'!R2C1:R" & LFin & "C15,12,FALSE),"""")"
          Rg.Value = Rg.Value
     ' Copie Filtre PCM
          Set Rg = .[M2].Resize(NbPML)
          Rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-12],'FS_semaine N'!R2C1:R" & LFin & "C15,13,FALSE),"""")"
          Rg.Value = Rg.Value
     ' Copie Filtre J3J4
          Set Rg = .[N2].Resize(NbPML)
          Rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-13],'FS_semaine N'!R2C1:R" & LFin & "C15,14,FALSE),"""")"
          Rg.Value = Rg.Value
     ' Copie Filtre Transfert
          Set Rg = .[O2].Resize(NbPML)
          Rg.FormulaR1C1 = "=IFERROR(VLOOKUP(RC[-14],'FS_semaine N'!R2C1:R" & LFin & "C15,15,FALSE),"""")"
          Rg.Value = Rg.Value
    End With
   
     'FIN DE LA PREPARATION
   
     'QUE FAUT-IL FAIRE ENSUITE ?
'COLLER EN FIN DE "FS_semaine N" :
   
     'Récupérer les données dans tbVal
     tbVal = Sh_PML.Cells(2, 1).Resize(NbPML, ColO).Value
     'Supprimer la feuille "Vierge" puis en recréer une
     Sh_PML.Delete
     With ThisWorkbook: .Worksheets.Add after:=.Worksheets(.Worksheets.Count): End With
     ActiveSheet.Name = "Vierge"
   
     'Collage des valeurs en fin de tableau tb_SN
     With Sh_SN
           Déb_Import = .Cells(.Rows.Count, ColF).End(xlUp).Row + 1         '(dernière ligne repérée en colonne F +1)
           .Rows(Déb_Import).Resize(.Rows.Count - Déb_Import + 1).Delete    'Nettoyage fin de tableau (s'il y a des "résidus" au delà de la fin de la colonne F
           .Cells(Déb_Import, 1).Resize(NbPML, ColO).Value = tbVal
     End With
   
   
     Set Rg = Nothing
     Set Sh_PML = Nothing
   
End Sub

Traiter_Extract_ALTIS

VB:

Sub Traiter_Extract_ALTIS()
     'Repère des colonnes
     Const C_A = 1, C_B = 2, C_C = 3, C_D = 4, C_E = 5, C_F = 6, C_G = 7, C_H = 8, C_I = 9, C_J = 10, C_K = 11, C_L = 12, C_M = 13, C_N = 14, C_O = 15, C_P = 16, C_Q = 17, C_R = 18, C_S = 19, C_T = 20, C_U = 21, C_V = 22, C_W = 23, C_X = 24, C_Y = 25, C_Z = 26, C_AA = 27, C_AB = 28, C_AC = 29, C_AD = 30, C_AE = 31, C_AF = 32, C_AG = 33, C_AH = 34, C_AI = 35, C_AJ = 36, C_AK = 37, C_AL = 38, C_AM = 39, C_AN = 40, C_AO = 41, C_AP = 42, C_AQ = 43, C_AR = 44, C_AS = 45, C_AT = 46, C_AU = 47, C_AV = 48, C_AW = 49, C_AX = 50, C_AY = 51, C_AZ = 52, C_BA = 53, C_BB = 54, C_BC = 55, C_BD = 56, C_BE = 57, C_BF = 58, C_BG = 59, C_BH = 60, C_BI = 61, C_BJ = 62, C_BK = 63, C_BL = 64, C_BM = 65, C_BN = 66, C_BO = 67, C_BP = 68, C_BQ = 69, C_BR = 70, C_BS = 71, C_BT = 72, C_BU = 73, C_BV = 74, C_BW = 75, C_BX = 76

     Dim Sh_ALTIS As Worksheet, Sh_Accueil As Worksheet, Sh_N As Worksheet, Sh_N_1 As Worksheet
     Dim Tout, TbRés
   
     With ThisWorkbook
          Set Sh_Accueil = .Worksheets("Accueil")
          Set Sh_ALTIS = .Worksheets("Vierge")
          Set Sh_N = .Worksheets("FS_semaine N")
          Set Sh_N_1 = .Worksheets("FS_semaine N-1")
     End With
     Application.ScreenUpdating = False
   
     FormulesAccueil = Sh_Accueil.[M4:S13].Formula
     With Sh_ALTIS
     'Pas de lignes filtrées
          If .FilterMode Then .ShowAllData
          .AutoFilterMode = False
          'Récupération des données de l'extraction (à partir de la ligne 3)
          Tout = .UsedRange.Offset(2).Resize(.UsedRange.Rows.Count - 2).Value
          Application.DisplayAlerts = False: .Delete: Application.DisplayAlerts = True
     End With
     With ThisWorkbook: .Worksheets.Add after:=.Worksheets(.Worksheets.Count): End With
     ActiveSheet.Name = "Vierge"
   
     'Première ligne
     Tout(1, C_X) = IIf(Tout(2, C_O) = "", Tout(1, C_X) & " " & Tout(2, C_X), Tout(1, C_X))
     'Comptage des fiches à retenir (Col O <>"" et <>0)
     nbFiches = 0
     nbFiches = nbFiches + (Abs(Tout(1, C_O) <> "") And Tout(1, C_O) <> "0" And Tout(1, C_O) <> 0)
     'Jusqu'à l'avant-dernière
     For i = 2 To UBound(Tout) - 1
          'Compléter les valeurs des cellules fusionnées utilisées
          If Tout(i, C_S) = "" Then Tout(i, C_S) = Tout(i - 1, C_S)
          If Tout(i, C_T) = "" Then Tout(i, C_T) = Tout(i - 1, C_T)
          If Tout(i, C_AA) = "" Then Tout(i, C_AA) = Tout(i - 1, C_AA)
          If Tout(i, C_AE) = "" Then Tout(i, C_AE) = Tout(i - 1, C_AE)
          If Tout(i, C_AG) = "" Then Tout(i, C_AG) = Tout(i - 1, C_AG)
          If Tout(i, C_AI) = "" Then Tout(i, C_AI) = Tout(i - 1, C_AI)
          If Tout(i, C_AK) = "" Then Tout(i, C_AK) = Tout(i - 1, C_AK)
          If Tout(i, C_AL) = "" Then Tout(i, C_AL) = Tout(i - 1, C_AL)
          Tout(i, C_X) = IIf(Tout(i + 1, C_O) = "", Tout(i, C_X) & " " & Tout(i + 1, C_X), Tout(1, C_X))
          'Comptage des fiches à retenir (Col O <>"" et <>0)
          nbFiches = nbFiches + (Abs(Tout(i, C_O) <> "") And Tout(i, C_O) <> "0" And Tout(i, C_O) <> 0)
     Next i
     'Dernière ligne
     nbFiches = nbFiches + (Abs(Tout(i, C_O) <> "") And Tout(i, C_O) <> "0" And Tout(i, C_O) <> 0)
   
     'Dimensionnement du tableau résultat
     ReDim TbRés(C_A To nbFiches, 1 To C_O)
     j = 0
     For i = 1 To UBound(Tout)
          If Tout(i, C_O) <> "" Then
               j = j + 1
               TbRés(j, C_A) = Tout(i, C_O)
               TbRés(j, C_B) = Tout(i, C_S)
               TbRés(j, C_C) = Tout(i, C_T)
               TbRés(j, C_D) = Tout(i, C_W)
               TbRés(j, C_E) = Evaluate("=IFERROR(VLOOKUP(" & TbRés(1, C_A) & ",Tb_SN,5,FALSE),""NEW / à éclaircir"")")
               TbRés(j, C_F) = Tout(i, C_AA)
               Select Case TbRés(j, C_F)
                    Case "INITIALIZATION": TbRés(j, C_G) = Tout(i, C_AE)
                    Case "INSTRUCTION": TbRés(j, C_G) = Tout(i, C_AG)
                    Case "DEVELOPMENT": TbRés(j, C_G) = Tout(i, C_AI)
                    Case "OFFICIALIZATION - INDUSTRIALIZATION": TbRés(j, C_G) = Tout(i, C_AK)
                    Case Else: TbRés(j, C_G) = Tout(i, C_AL)
               End Select
               TbRés(j, C_I) = Tout(i, C_X)
               TbRés(j, C_J) = Evaluate("=IFERROR(VLOOKUP(" & TbRés(1, C_A) & ",Tb_SN,9,FALSE),""NEW / à classer"")")
               TbRés(j, C_K) = Evaluate("=IFERROR(VLOOKUP(" & TbRés(1, C_A) & ",Tb_SN,10,FALSE),""NEW / à programmer"")")
               TbRés(j, C_L) = Evaluate("=IFERROR(VLOOKUP(" & TbRés(1, C_A) & ",Tb_SN,11,FALSE),"""")")
               TbRés(j, C_M) = Evaluate("=IFERROR(VLOOKUP(" & TbRés(1, C_A) & ",Tb_SN,13,FALSE),"""")")
               TbRés(j, C_N) = Evaluate("=IFERROR(VLOOKUP(" & TbRés(1, C_A) & ",Tb_SN,14,FALSE),"""")")
               TbRés(j, C_O) = Evaluate("=IFERROR(VLOOKUP(" & TbRés(1, C_A) & ",Tb_SN,15,FALSE),"""")")
          End If
     Next i
   
   
     With Sh_N
          'Lectures des données de l'ancienne semaine N
          Tout = .[Tb_Sn].Value
          'Remplissage semaine N avec les données de la nouvelle extraction
          .[Tb_Sn].ClearContents
          .[Tb_Sn].ListObject.Resize .[Tb_Sn].ListObject.Range.Resize(UBound(TbRés))
          .[Tb_Sn].Value = TbRés
     End With
   
     ' Identification dans Tout des FS de l'ancienne semaine N absentes de la nouvelle extraction
     With WorksheetFunction
     For i = 1 To UBound(Tout)
          Tout(i, C_F) = Evaluate("=IFERROR(VLOOKUP(" & Tout(i, C_A) & ",Tb_SN,6,FALSE),""soldé ou abandonné"")")
          Tout(i, C_G) = Evaluate("=IFERROR(VLOOKUP(" & Tout(i, C_A) & ",Tb_SN,7,FALSE),""soldé ou abandonné"")")
     Next
     End With
   
     'Transfert vers la semaine N-1
     With Sh_N_1
          'Remplissage semaine N-1 avec les données de l'ancienne semaine N
          .[Tb_Sn_1].ClearContents
          .[Tb_Sn_1].ListObject.Resize .[Tb_Sn_1].ListObject.Range.Resize(UBound(Tout))
          .[Tb_Sn_1].Value = Tout
     End With
      Application.ScreenUpdating = True
End Sub

Macro pour filtrer les Fiches

VB:

Sub Filtrage()

     Dim Sh_SN As Worksheet, lo As ListObject
   
     'Quel bouton a appelé la macros ?
     Typ = Application.Caller
   
     Set Sh_SN = ThisWorkbook.Worksheets("FS_semaine N")
     Set lo = Sh_SN.ListObjects(1)
   
     With lo
          If .AutoFilter Is Nothing Then .Range.AutoFilter
          .AutoFilter.ShowAllData
          Select Case Typ         'En fonction du nom de l'objet qui a appelé la macro on applique les filtre adéquat
               Case "Qual_DV"
                    .Range.AutoFilter Field:=3, Criteria1:=Array("PEPP DV", "PEPP VSUD Transversal", "="), Operator:=xlFilterValues
                    .Range.AutoFilter Field:=9, Criteria1:=Array("Qualité/Indus/Communauté", "=NEW / à classer"), Operator:=xlFilterValues
               Case "Qual_DW"
                    .Range.AutoFilter Field:=3, Criteria1:=Array("PEPP DW", "PEPP VSUD Transversal", "="), Operator:=xlFilterValues
                    .Range.AutoFilter Field:=9, Criteria1:=Array("Qualité/Indus/Communauté", "NEW / à classer"), Operator:=xlFilterValues
               Case "DA_eco_DV"
                    .Range.AutoFilter Field:=3, Criteria1:=Array("PEPP DV", "PEPP VSUD Transversal", "="), Operator:=xlFilterValues
                    .Range.AutoFilter Field:=9, Criteria1:=Array("Ecotechs/Achats", "NEW / à classer"), Operator:=xlFilterValues
               Case "DA_eco_DW"
                    .Range.AutoFilter Field:=3, Criteria1:=Array("PEPP DW", "PEPP VSUD Transversal", "="), Operator:=xlFilterValues
                    .Range.AutoFilter Field:=9, Criteria1:=Array("Ecotechs/Achats", "NEW / à classer"), Operator:=xlFilterValues
          End Select
     End With
   
     Application.Goto Sh_SN.[C2], True 'Aller en haut et à gauche de la liste (avec déplacement de la fenêtre)
   
End Sub

Voir pièce jointe
Bon courage

SAAD doli · 31 Mars 2023

AtTheOne à dit:
Re,
Dans ton exemple d'extraction ALTIS il y a des cellules fusionnées, faut-il remplir toutes les lignes de ces plages fusionnées avec la valeur affichée ?
En particulier pour les colonnes S et T que l'on retrouve en colonne B et C après traitement.

De plus je ne comprends pas bien la mécanique dans la colonne Y pour remplir la colonne X (col H après traitement) à partir de la colonne O : "=IF(ISBLANK(R[1]C[-10]),CONCATENATE(RC[-1],"" "",R[1]C[-1]),RC[-1])"
Si la colonne O est vide, on concatène X, un espace et la valeur X de la ligne du dessous, sinon on prend la valeur de X.
Est-bien cela ? car ce n'est pas conforme à ton commentaire :

'verifier si O3 est vide sinon concaténer "X3 Z3"-> X3
(Ton tableau n'est pas trié au moment ou la macro fait cela)
Merci de me répondre, ça a une influence sur ce que je veux faire...

oui , c'est bien ca
Si la colonne O est vide, on concatène X, un espace et la valeur X de la ligne du dessous, sinon on prend la valeur de X

Autres ActiveWorkbook.Worksheets("vierge").AutoFilter.Sort.SortFields.Clear

XLDnaute Nouveau

XLDnaute Accro

XLDnaute Nouveau

XLDnaute Accro

XLDnaute Nouveau

Pièces jointes

XLDnaute Accro

XLDnaute Accro

XLDnaute Accro

Pièces jointes

XLDnaute Nouveau

Pièces jointes

XLDnaute Nouveau

Pièces jointes

XLDnaute Accro

XLDnaute Accro

XLDnaute Accro

XLDnaute Accro

Pièces jointes

XLDnaute Nouveau

Discussions similaires

Partager cette page

Statistiques des forums