Sub CtlUNSPSC()
[COLOR="SeaGreen"]'
' ¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ '
' ¤ 29 Pluviôse CCXVII - ROGER2327 fecit. ¤ '
' ¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤ '
' Révision le 30 Pluviôse CCXVII (Contrôle des valeurs extrèmes)
' Modification le 8 Floréal CCXVII (Sorie des données en colonne S)
'[/COLOR]
Dim i As Long, j As Long, ctl(), dat(), cod(), Uctl As Long, Ldat As Long, Lcod As Long, cd
Application.ScreenUpdating = False
ReDim ctl(1 To 2, 1 To 1)
ctl(1, 1) = "Code UNSPSC INCOHERENT"
Uctl = 1
With Sheets("DATA")
dat = .Range(.Cells(1, 49), .Cells(Rows.Count, 49).End(xlUp)).Value
ReDim Preserve dat(1 To UBound(dat, 1), 1 To 3)
For Each cd In .Range(.Cells(1, 49), .Cells(Rows.Count, 49).End(xlUp)).Cells
Ldat = Ldat + 1: dat(Ldat, 2) = cd.Address: dat(Ldat, 3) = cd.Row
Next cd
End With
With Sheets("Code UNSPSC")
cod = .Range(.Cells(1, 2).End(xlDown), .Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)).Value
ReDim Preserve cod(1 To UBound(cod, 1), 1 To 2)
cod(UBound(cod, 1), 1) = Chr(255)
cod(UBound(cod, 1), 2) = Chr(255)
For Each cd In .Range(.Cells(1, 2).End(xlDown), .Cells(Rows.Count, 2).End(xlUp)).Cells
Lcod = Lcod + 1: cod(Lcod, 2) = cd.Address
Next cd
Lcod = Lcod + 1
End With
Sheets.Add Before:=Worksheets(Me.Name)
With ActiveSheet
With .Range(.Cells(1, 1), .Cells(Ldat, 3))
.Value = dat
.Sort Key1:=.Range("A1"), Order1:=xlAscending, Key2:=.Range("C1"), Order2:=xlAscending, _
Header:=xlYes, Orientation:=xlSortColumns, DataOption1:=xlSortTextAsNumbers
dat = .Value
End With
.Cells.Clear
With .Range(.Cells(1, 1), .Cells(Lcod, 2))
.Value = cod
.Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlYes, Orientation:=xlSortColumns, _
DataOption1:=xlSortTextAsNumbers
cod = .Value
End With
.Cells.Clear
j = 2
For i = 2 To Ldat
cd = dat(i, 1)
For j = j To Lcod
If cd <= cod(j, 1) Then
If cd < cod(j, 1) Then
Uctl = Uctl + 1
ReDim Preserve ctl(1 To 2, 1 To 1 + Uctl)
ctl(1, Uctl) = Replace(dat(i, 2), "$", "")
ctl(2, Uctl) = dat(i, 3)
End If
Exit For
End If
Next j
Next i
ctl = Application.Transpose(ctl)
With .Range(.Cells(1, 1), .Cells(Uctl, 2))
.Value = ctl
.Sort Key1:=.Range("B1"), Order1:=xlAscending, Header:=xlYes, Orientation:=xlSortColumns
ctl = .Value
End With
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
ReDim Preserve ctl(1 To Uctl, 1 To 1)
[COLOR="SeaGreen"]' ctl = Application.Transpose(ctl)
' With Sheets("CONTROLE")
' .Range(.Cells(19, 1), .Cells(19, Columns.Count).End(xlToLeft)).ClearContents
' .Range(.Cells(19, 1), .Cells(19, Uctl)).Value = ctl
' End With[/COLOR]
[COLOR="Red"][B]With Sheets("CONTROLE")[/B][/COLOR] [COLOR="SeaGreen"]' modifié le 8 Floréal CCXVII[/COLOR]
[COLOR="Red"][B].Range(.Cells(11, 19), .Cells(Rows.Count, 19).End(xlUp)).ClearContents
.Range(.Cells(11, 19), .Cells(Uctl + 10, 19)).Value = ctl
End With[/B][/COLOR]
Application.ScreenUpdating = True
End Sub
