1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95
| Sub Max_Pkg() '--------------- Macro Fin de Picking -------------------
Dim i As Variant
Dim j As Variant
Dim CelDprt1, CelDprt2 As Long
Dim CelFin1, CelFin2 As Long
Dim DernCol As String
Dim ColNum As Long
Dim DernLign As Long
Dim DateImport, MadTh, FinPkg As Long
ColNum = Cells(1, Columns.Count).End(xlToLeft).Column 'determine la derniere valeur ligne 1
DernCol = GetColumnLetter(ColNum) 'determine la lettre correspondant a la dernière colonne ligne 1
DernLign = Range("A1048576").End(xlUp).Row 'determine la derniere valeur colonne A
'-------------- Determine les numéros de colonnes DateImport / MaD Théorique / Fin de Picking ----------
For Each x In Range("A1:" & DernCol & ColNum)
If x = "Date import" Then
Range(x, x.End(xlToLeft)).Select
DateImport = Selection.Cells.SpecialCells(xlCellTypeConstants).Count
End If
If x = "Mise à dispo théorique" Then
Range(x, x.End(xlToLeft)).Select
MadTh = Selection.Cells.SpecialCells(xlCellTypeConstants).Count
End If
If x = "Fin Picking" Then
Range(x, x.End(xlToLeft)).Select
FinPkg = Selection.Cells.SpecialCells(xlCellTypeConstants).Count
End If
Next
'-------------- Filtre les données par Date Import puis MaD Théorique et enfin par heure de Fin de Picking ------------------
Range("A1").CurrentRegion.Select
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add Key:=Range(Cells(2, DateImport), Cells(DernLign, DateImport)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveSheet.Sort.SortFields.Add Key:=Range(Cells(2, MadTh), Cells(DernLign, MadTh)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveSheet.Sort.SortFields.Add Key:=Range(Cells(2, FinPkg), Cells(DernLign, FinPkg)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveSheet.Sort
.SetRange Range("A1:" & DernCol & DernLign)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'-------------- Converti les données des heures de la colonne Fin de picking -------------------------
Columns(FinPkg).Select
Selection.TextToColumns , DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
'-------------- Loop parmi DateImport, puis MaD Théorique pour determiner le max de Fin de Picking -------------------------
For i = 2 To DernLign
If Cells(i - 1, DateImport) <> Cells(i, DateImport) Then ' cas ou la référence est différente
CelDprt1 = i
Do
i = i + 1
Loop While Cells(i, DateImport) = Cells(i + 1, DateImport) Or IsEmpty(Cells(i, DateImport))
CelFin1 = i
For j = CelDprt1 To CelFin1
If Cells(j - 1, MadTh) <> Cells(j, MadTh) Then ' cas ou la référence est différente
CelDprt2 = j
Do
j = j + 1
Loop While Cells(j, MadTh) = Cells(j + 1, MadTh) And IsEmpty(Cells(j, MadTh))
CelFin2 = j
For k = CelDprt2 To CelFin2
Cells(k, 51).FormulaR1C1 = "=MAX(R" & CelDprt2 & "C" & FinPkg & ":R" & CelFin2 & "C" & FinPkg & ")"
'Variable Cells(k, 51) a changer pour l'emplacement du resultat de la formule max
'exemple 51 = colonne AY, change en 1 pour colonne A etc ...
Next
End If
Next
End If
Next
Columns("AY:AY").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
End Sub |
Partager