Lettrage Numero facture

**roadrunner34** · 12/06/2014, 12h02

bonjour
j'ai besoin d'identifier sur deux colonnes les valeurs identiques et de les "flaguer" par une lettre différente un peu comme pour un lettrage comptable.
dans la colonne "c" j'ai des numéros de factures, dans la colonne "d" j'ai du texte plus ces numéros de factures concaténés.
l'idée c'est de sélectionner la première cellule de C et de rechercher ce "texte" dans "D".
si rien n'est trouvé passer à la suivante.
Si une correspondance est trouvé, il faudrait indiquer en face de chaque cellule dans une troisième colonne une lettre identique aux valeurs recherchées et trouvées.
puis passer à la cellule suivante etc ...
exemple dans la PJ où surligné en jaune on voit les valeurs communes marqués en "a", en bleu idem marqué en "b" et ainsi de suite.
merci de votre aide

Classeur2.xlsx

Invité · 12/06/2014, 16h08

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub test()
Dim R As Range
Dim L As Long
Dim i As Long
Dim Occurrence As Long
Dim trouve As Boolean
Set R = ActiveSheet.UsedRange
Occurrence = 0
For i = 2 To R.Rows.Count
    L = 1
trouve = False
    Do While L <> 0
        L = SerchXls(ActiveSheet.Range("d:d"), ActiveSheet.Range("d" & L), R(i, 3), False)
        If L > 0 Then
        If trouve = False Then Occurrence = Occurrence + 1
        trouve = True
        R(i, 5) = CalculOccurence(Occurrence)
        R(L, 6) = R(i, 5)
        End If
    Loop
Next
End Sub
 
Function CalculOccurence(Occurrence) As String
Dim t As String
Dim C As Integer
Dim ICH As Integer
C = Occurrence
t = Space(Occurrence)
ICH = 0
For i = 0 To Occurrence - 1
    If Mid(t, C, 1) = "Z" Then
        Mid(t, C, 1) = "A": C = C - 1
        ICH = 0
   End If
 
       Mid(t, C, 1) = Chr(65 + ICH)
       ICH = ICH + 1
 
 
Next
CalculOccurence = Trim(t)
End Function
 
 
Function SerchXls(MyRange As Range, MyCellule As Range, strRecherche, EntierCell As Boolean) As Long '
On Error Resume Next
SerchXls = 0
Dim myxLookAt As Integer
If EntierCell = True Then myxLookAt = xlWhole Else myxLookAt = xlPart
   SerchXls = MyRange.Cells.Find(What:=strRecherche, After:=MyCellule, LookIn:=xlFormulas, LookAt _
        :=myxLookAt, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
    False, MatchByte:=False).Row
  If SerchXls <= MyCellule.Row Then SerchXls = 0
End Function

**roadrunner34** · 12/06/2014, 17h02

Bonsoir Robert
merci pour le code qui est totalement opérationnel !
Trop TOP !!

que se passe t il à la 27 occurrence ? après le Z ?

Invité · 12/06/2014, 17h08

AA
BA
CA
ZA
AAA
BAA
CAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA

**roadrunner34** · 12/06/2014, 17h09

Bravo Robert
je viens de tester avec plus de valeurs
c'est excellentissime !!

MERCI MERCI
Tu mérite bien le nom d'expert !!

**roadrunner34** · 12/06/2014, 17h24

Sur une liste de 500 lignes
Le calcul Excel semble s'affoler puis Excel plante...

Invité · 13/06/2014, 00h18

Envoyé par roadrunner34

Sur une liste de 500 lignes
Le calcul Excel semble s'affoler puis Excel plante...

je suis allé très loin !

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub test()
Dim R As Range
Dim L As Long
Dim i As Long
Dim Occurrence As Long
Dim trouve As Boolean
Set R = ActiveSheet.UsedRange
Occurrence = 0
For i = 2 To R.Rows.Count
    L = 1
trouve = False
    If Trim("" & R(i, 3)) <> "" Then
        Do While L <> 0
            L = SerchXls(ActiveSheet.Range("d:d"), ActiveSheet.Range("d" & L), R(i, 3), False)
            If L > 0 Then
            If trouve = False Then Occurrence = Occurrence + 1
            trouve = True
            R(i, 5) = CalculOccurence(Occurrence)
            R(L, 6) = R(i, 5)
            End If
        Loop
    End If
Next
MsgBox "Fin"
End Sub
 
Function CalculOccurence(Occurrence) As String
Dim t As String
Dim C As Integer
Dim ICH As Integer
C = Occurrence
t = Space(Occurrence)
ICH = 0
For i = 0 To Occurrence - 1
    If Mid(t, C, 1) = "Z" Then
        Mid(t, C, 1) = "A": C = C - 1
        ICH = 0
   End If
 
       Mid(t, C, 1) = Chr(65 + ICH)
       ICH = ICH + 1
 
 
Next
CalculOccurence = Trim(t)
End Function
 
 
Function SerchXls(MyRange As Range, MyCellule As Range, strRecherche, EntierCell As Boolean) As Long '
On Error Resume Next
SerchXls = 0
Dim myxLookAt As Integer
If EntierCell = True Then myxLookAt = xlWhole Else myxLookAt = xlPart
   SerchXls = MyRange.Cells.Find(What:=strRecherche, After:=MyCellule, LookIn:=xlFormulas, LookAt _
        :=myxLookAt, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
    False, MatchByte:=False).Row
  If SerchXls <= MyCellule.Row Then SerchXls = 0
End Function

Invité · 13/06/2014, 09h49

une petite variante qui en fait est une grande révolution!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub test()
Dim R As Range
Dim L As Long
Dim i As Long
Dim Occurrence As Long
Dim trouve As Boolean
Set R = ActiveSheet.UsedRange
Occurrence = 0
For i = 2 To R.Rows.Count
    L = 1
trouve = False
    If Trim("" & R(i, 3)) <> "" Then
        Do While L <> 0
            L = SerchXls(ActiveSheet.Range("d:d"), ActiveSheet.Range("d" & L), R(i, 3), False)
            If L > 0 Then
            If trouve = False Then Occurrence = Occurrence + 1
            trouve = True
            R(i, 5) = CalculOccurence(Occurrence)
            R(L, 6) = R(i, 5)
            End If
        Loop
    End If
Next
MsgBox "Fin"
End Sub
 
Function CalculOccurence(Occurrence As Long) As String
Dim t As String
Dim C As Long
Dim ICH As Integer
 
t = Space(Occurrence)
 
For i = 0 To Occurrence - 1
    t = AZ_AutoIncrement(t, Occurrence)
 
 
Next
CalculOccurence = Trim(t)
End Function
 
 Function AZ_AutoIncrement(ByVal t, C As Long) As String
 Dim a As String
 a = t
 If Mid(t, C, 1) = " " Then Mid(t, C, 1) = "A": AZ_AutoIncrement = t: Exit Function
 If Mid(t, C, 1) = "Z" Then Mid(t, C, 1) = "A":  AZ_AutoIncrement = AZ_AutoIncrement(t, C - 1): Exit Function
Mid(t, C, 1) = Chr(Asc(Mid(t, C, 1)) + 1)
AZ_AutoIncrement = t
 End Function
 
Function SerchXls(MyRange As Range, MyCellule As Range, strRecherche, EntierCell As Boolean) As Long '
On Error Resume Next
SerchXls = 0
Dim myxLookAt As Integer
If EntierCell = True Then myxLookAt = xlWhole Else myxLookAt = xlPart
   SerchXls = MyRange.Cells.Find(What:=strRecherche, After:=MyCellule, LookIn:=xlFormulas, LookAt _
        :=myxLookAt, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
    False, MatchByte:=False).Row
  If SerchXls <= MyCellule.Row Then SerchXls = 0
End Function

**roadrunner34** · 13/06/2014, 12h14

Bonjour Robert
merveilleux!
tout fonctionne parfaitement !
je vais essayer de disséquer tout ça pour comprendre!

Mille merci

Lettrage Numero facture

Macros et VBA Excel

Discussions similaires

Partager

Partager