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
| Sub nouveau() 'Traitement Pour la Feuil2 si tu inverse Feuill1 adapte le code.
Dim i, j As Integer
Dim cond1, cond2, cond3 As Double
Dim cellule, plage As Range, multiple_cde, seuil As Range
'Initialiser a zero le tableau de valeurs a traiter
On Error Resume Next
Set plage = Application.InputBox("Selection de la plage de cellules a initialiser à zéro:", "Sélectionnez la plage de cellules à initialiser a zéro:", Type:=8)
On Error GoTo 0
If plage Is Nothing Then MsgBox "Sélection annulée"
plage.Value = "0"
For L = 1 To plage.Rows.Count
For C = 1 To plage.Columns.Count
plage(L, C) = RéférenceDate(ActiveSheet.Cells(plage(L, C).Row, 1), ActiveSheet.Cells(1, plage(L, C).Column), "Feuil1", "A", RetourneColonne("Feuil1", ActiveSheet.Cells(1, plage(L, C).Column)), RetourneColonne("Feuil1", ActiveSheet.Cells(1, plage(L, C).Column)))
Next
Next
End Sub
'RéférenceDate fonction personnalisé par l'utilisateur
'Auteur RDurupt.
'Cette fonction se comporte comme un rechercheV a double entrées !
'En d 'autre terme elle recherche de valeurs selon deux critères !
'RéférenceDate:
'******************************************************************************************************************
'* 1) Reff : la référence à chercher *
'* 2) Ladate : la date à chercher *
'* 3) Feuille : feuille ou rechercher *
'* 4) ReffC : Colonne ou ce trouve la référence sheets( Feuille).Range(ReffC & ":" & ReffC) ' Colonne A *
'* 5) LadateC : Colonne ou ce trouve la Date sheets( Feuille).Cells(L, LadateC ) ' Colonne B & L *
' *6) RetournC : Colonne ou ce trouve la Valeur a retourner sheets( Feuille).Cells(L, LadateC ) ' Colonne C & L *
'******************************************************************************************************************
Function RéférenceDate(Reff, Ladate, Feuille As String, ReffC As String, LadateC As String, RetournC) As Double
Dim L As Long
L = 1
Do While L > 0
L = SerchXls(Sheets(Feuille).Range(ReffC & ":" & ReffC), Sheets(Feuille).Range(ReffC & L), Reff, True)
If L > 0 Then
'A est diférent de a ces pour cela que je passe en majuscule!
If UCase(Trim("" & Sheets(Feuille).Cells(1, LadateC))) = UCase(Trim("" & Ladate)) Then RéférenceDate = RéférenceDate + CDbl(Sheets(Feuille).Cells(L, RetournC))
End If
Loop
End Function
'RetourneColonne fonction personnalisé par l'utilisateur
'Auteur RDurupt.
'Retourne l'adresse de la colonne recherchée par son entête (A ;B ;C ;…)!
'******************************************************************************************************************
'* 1) Feuille : feuille ou rechercher *
'* 2)Nom : 'entête de colonne (mois1;Mois2:...) *
'******************************************************************************************************************
Function RetourneColonne(Feuille As String, Nom As String) As String
Dim C As Long
For C = 1 To Sheets(Feuille).UsedRange.Columns.Count 'Scan les colonnes
'Compare l'entête de la colonne avec le nom passé en paramètre (MoiS1 ;Mois2 ;…)=Nom ?
If Sheets(Feuille).Cells(1, C) = Nom Then RetourneColonne = Split(Sheets(Feuille).Cells(1, C).Address, "$")(1): Exit Function
' Split Découpe sous forme de tableau une chaine de caractère en fonction d'un autre ($)
' [$A$1] retourne un tableau ["" ; "A" ; "1" ; ""] don A est en position (1)
Next
End Function
'SerchXls fonction personnalisé par l'utilisateur
'Auteur RDurupt.
'Retourne le N° de ligne (Row) de la valeur recherché ou zéro si pas trouvé !
'L'idée est de faire un gestionnaire de recherche universel autonome utilisable à volonté !
'l'enregistreur de macro te donnes une solution approchante !
'******************************************************************************************************************
'* 1) Myrange : Plage de célulles impliquées par la recherche * *
'* 2) MyCellule : Célulle de départ si la valeur cherché ce trouve en ligne 2 alors que le départ est en ligne 10*
'* cela veut dire que la recherche à bouclé donc retourne 0 *
'* 3) strRecherche : valerer a recherché *
'* 4) EntierCell défini si la recheche ce fait sur la célulle entière ou un fragment. *
'******************************************************************************************************************
Function SerchXls(Myrange As Range, MyCellule As Range, strRecherche, EntierCell As Boolean) As Long
On Error Resume Next
Dim CellEntrier As Integer
If EntierCell = True Then CellEntrier = xlWhole Else CellEntrier = xlPart
SerchXls = 0
SerchXls = Myrange.Cells.Find(what:=strRecherche, After:=MyCellule, LookIn:=xlFormulas, LookAt _
:=CellEntrier, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=EntierCell).Row
If SerchXls <= MyCellule.Row Then SerchXls = 0
End Function |
