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
| Sub genere_onglets_fournisseur_TEST()
Dim Col As Variant, DL As Long, Plage As Range, VA As Variant, I As Long, NewColl As New Collection, NC As Variant, Lig As Variant, VB As Variant, DimTab As Integer, NomFeuille As String
Dim Col_Acro As Byte, Col_X As Byte
Dim ligne As Variant
Dim start As Single
Dim finish As Single
Dim LettreVoulue As String
If sheetExists("R_MoulinetteAValider") = False Then
MsgBox "Erreur d'exécution, la feuille R_MoulinetteAValider est manquante !!!", vbCritical, "ERREUR"
Exit Sub
Else
End If
Col_Acro = [fournisseur_titre].Column
Col_X = [valider_fournisseur_titre].Column
start = Timer
Col = Array([ID_titre].Column, [seq_titre].Column, [pair_impair_titre].Column, [etab_titre].Column, [acronyme_etab_titre].Column, _
[item_etab_moulinette_titre].Column, [item_etab_titre].Column, [descr_etab_titre].Column, [couleur_etab_titre].Column, [four_etab_titre].Column, _
[fournisseur_titre].Column, [marque_etab_titre].Column, [cat_etab_titre].Column, [format_contrat_titre].Column, [qte_an_titre].Column, _
[prix_contrat_titre].Column, [valider_fournisseur_titre].Column, [commentaire_fournisseur_titre].Column)
Sheets("R_MoulinetteAValider").Activate
LettreVoulue = TrouveLettreColonne([Fournisseur])
Range(LettreVoulue & 2, LettreVoulue & LastLignUsedInSheet("R_MoulinetteAValider")).Select
Selection.Replace What:=Chr(47), Replacement:=Chr(32)
Selection.Replace What:=Chr(92), Replacement:=Chr(32)
Selection.Replace What:=Chr(91), Replacement:=Chr(32)
Selection.Replace What:=Chr(93), Replacement:=Chr(32)
nettoyerseul
With Sheets("R_MoulinetteAValider")
DL = .Cells(.Rows.Count, 1).End(xlUp).Row
Set Plage = .Range(Range("A2"), Range(TrouveLettreColonne([commentaire_fournisseur_titre]) & DL))
VA = Plage
' Set Plage = Nothing
Application.ScreenUpdating = False
On Error Resume Next
For I = 1 To UBound(VA)
If UCase(VA(I, Col_X)) = "X" Then
NewColl.Add UCase(VA(I, Col_Acro)) & "|" & I, UCase(VA(I, Col_Acro))
If Err Then
Err.Clear
ligne = NewColl(UCase(VA(I, Col_Acro)))
NewColl.Remove UCase(VA(I, Col_Acro))
NewColl.Add ligne & "|" & I, UCase(VA(I, Col_Acro))
End If
.Cells(I + 1, Col_X).value = "Extraction OK"
End If
Next
On Error GoTo 0
End With
For Each NC In NewColl
NomFeuille = Mid(NC, 1, InStr(NC, "|") - 1)
Lig = Application.Transpose(Split(NC, "|"))
Lig = Application.Index(Lig, Evaluate("Row(2:" & UBound(Lig) & ")"))
VB = Application.Index(Plage, Lig, Col) 'VB = Application.Index(VA, Lig, Col)
DimTab = Len(NC) - Len(Replace(NC, "|", ""))
If Not sheetExists(NomFeuille) Then
Sheets.Add , Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = NomFeuille
En_Tete_fourn NomFeuille
With ActiveSheet.Tab
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.599993896298105
End With
End If
With Sheets(NomFeuille)
DL = .Cells(.Rows.Count, 1).End(xlUp)(2).Row
If DimTab > 1 Then .Cells(DL, 1).Resize(UBound(VB), UBound(VB, 2)).value = VB _
Else .Cells(DL, 1).Resize(, UBound(VB)).value = VB
End With
Next
Set Plage = Nothing
finish = Timer
MsgBox "durée du traitement: " & finish - start & " secondes"
Application.ScreenUpdating = True
End Sub |
