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 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164
| Sub Macro1()
On Error GoTo Err_Commande86_Click
'
' Macro1 Macro
' Macro enregistrée le 31/03/2009 par *********
'
Range("I3:Bl500").Select
Selection.Interior.ColorIndex = xlNone
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
Selection.ClearComments
'
' à quoi cela correspond-il??
col = 8
a = ""
b = ""
c = ""
c1 = ""
c2 = ""
d = ""
e = ""
f = ""
cpt = 1
lots = ""
sem = ""
cumul = 0
nb = 0
For Each cellule In ActiveSheet.Range("A3:h500").Cells
f = e
e = d
d = c2
c2 = c1
c1 = c
c = b
b = a
a = cellule
If (cpt = col) Then
If (b <= Range("c1").Value) Then
sem = sem & "Sem " & Format(b, "ww", vbMonday, vbFirstJan1) & ";"
End If
End If
If (cpt = col And f = "") Then
lots = lots & cellule.Value & ";"
nb = nb + 1
End If
If (cpt = col And f <> "") Then
cumul = 0
cumul2 = 0
sous_total = 0
If (nb > 0) Then
sous_total = InStr(1, lots, ";")
sous_total = Mid(lots, 1, sous_total)
sous_total = Replace(sous_total, ";", "")
sous_total = Round(sous_total, 2)
lots = Replace(lots, sous_total & ";", "", 1, 1)
nb = nb - 1
End If
num_lot = 1
test = True
For Each Cellule2 In ActiveSheet.Range("L" & cellule.Row & ":BL" & cellule.Row).Cells
If (Cellule2.Value <> "") Then cumul = Int(Cellule2.Value) + cumul
If (Cellule2.Value <> "") Then cumul2 = Int(Cellule2.Value) + cumul2
ad = InStrRev(Cellule2.AddressLocal, "$")
ad = Mid(Cellule2.AddressLocal, 1, ad)
If (InStr(sem, Range(ad & "2").Value)) Then
Cellule2.Select
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 5
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 5
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 5
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 5
End With
sem = Replace(sem, Range(ad & "2").Value & ";", "")
End If
If (cumul2 > sous_total And nb > 0) Then
Cellule2.Select
With Selection.Interior
.ColorIndex = 44
End With
Selection.AddComment
Selection.Comment.Visible = True
Selection.Comment.Text Text:="Fin de lot " & num_lot & "." & Chr(10) & cumul2 - sous_total & " KG pris sur le lot suivant."
Selection.Comment.Visible = False
cumul2 = cumul2 - sous_total
num_lot = num_lot + 1
sous_total = InStr(1, lots, ";")
sous_total = Mid(lots, 1, sous_total)
sous_total = Replace(sous_total, ";", "")
sous_total = Round(sous_total, 2)
lots = Replace(lots, sous_total & ";", "", 1, 1)
nb = nb - 1
End If
If (cumul > cellule.Value And test = True) Then
Cellule2.Select
With Selection.Interior
.ColorIndex = 3
End With
Selection.ClearComments
Selection.AddComment
Selection.Comment.Visible = True
Selection.Comment.Text Text:="Rupture :" & Chr(10) & "Manque de " & cumul - cellule.Value & " KG"
Selection.Comment.Visible = False
sous_total = 0
lots = ""
cumul2 = 0
nb = 0
test = False
'Exit For
End If
Next
End If
cpt = 1 + cpt
If (cpt > col) Then
cpt = 1
End If
Next
Range("A1").Select
Exit_Commande86_Click:
Exit Sub
Err_Commande86_Click:
MsgBox Err.Description
Resume Exit_Commande86_Click
End Sub |
Partager