Bonjour,
La macro ci-jointe s'exécute (presque) correctement à ceci près que sur la dernière ligne j'ai une erreur du type :
"Erreur définie par l'application ou par l'objet"
Si j'insiste un petit peu en essayant de relancer avec F8, j'ai alors
Erreur automation -2147221080 (800401A8)
En fait il s'agit d'un truc en apparence tout bête :
Je charge un Array de la manière suivante :
Code : Sélectionner tout - Visualiser dans une fenêtre à part
Arc = WsC.Range(WsC.Cells(3, 1), WsC.Cells(iLR, iLC)).Value
Je modifie quelques valeur dans cet Array
puis je restitue l'Array dans la feuille :
Code : Sélectionner tout - Visualiser dans une fenêtre à part
WsC.Range(WsC.Cells(3, 1), WsC.Cells(iLR, iLC)) = Arc
Un tiers environ du transfert se fait bien mais cette dernière ligne (46) est surlignée. et il est impossible d'afficher les dernières valeurs de l'Array.
J'ai vérifié dans la fenêtre d'exécution quelques-unes des valeurs manquantes : Elles sont bien affichés preuve que l'Array à bien été chargé avec les valeurs exactes jusqu'à sa dernière ligne, mais refusent de s'afficher sur la feuille cible au-delà de la ligne 497 (sur les quelques 1580 que comporte l'Array)
Le code de la macro :
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
61
62
63
64
65
66
Option Explicit
 
Sub Galopin()
      Dim WsS As Worksheet, WsC As Worksheet, Dico, Dec%, iiR%, iLR%, iMR%, iC%, iR%, iLC%, i%, j%, Arr, Ref, Arc
1         Application.ScreenUpdating = False
2         Set WsS = Worksheets("GENERAL")                               'Feuille Source
3         Sheets.Add After:=Worksheets("GENERAL")
4         Set WsC = Worksheets(ActiveSheet.Name)                        'Feuille Cible
5         WsS.Rows("1:2").Copy WsC.Range("A1")
6         iLC = WsS.Cells(1, Columns.Count).End(xlToLeft).Column + 2
7         iLR = 0
8         For i = 2 To iLC
9             iLR = Application.Max(iLR, WsS.Cells(WsS.Rows.Count, i).End(xlUp).Row)
10        Next i
11        iLR = iLR - 1                         'les totaux ne nous intéressent pas
12        iMR = iLR                             'IMR mémorise la dernière ligne de la Source
13        Set Dico = CreateObject("Scripting.Dictionary")
14        For j = 2 To iLC - 2 Step 4
15          If WsS.Cells(3, j) = "Analyse" Or WsS.Cells(3, j) = "" Then 'Suppression des Analyse/Nombre
16            Range(WsS.Cells(3, j), WsS.Cells(3, j + 2)).Delete Shift:=xlUp
17          End If
18          For i = 3 To iLR
19             Dico(KDic(WsS.Cells(i, j).Text)) = ""
20          Next i
21        Next j
22        WsC.Range("A3").Resize(Dico.Count, 1) = Application.Transpose(Dico.keys)
23        iLR = WsC.Range("A" & WsC.Rows.Count).End(xlUp).Row          'iLR fait désormais référence à la feuille Cible (WsC)
            'Tri sur Clef primaire et suppression de la clef
24          WsC.Range("A3").Resize(Dico.Count, 1).Sort Key1:=WsC.Range("A3"), Order1:=xlAscending, Header:=xlNo
25          Ref = WsC.Range(WsC.Cells(3, 1), WsC.Cells(iLR, 1)).Value
26          For i = 1 To UBound(Ref)
27            Ref(i, 1) = Mid(Ref(i, 1), 2)
28          Next i
29          WsC.Range(WsC.Cells(3, 1), WsC.Cells(iLR, 1)) = Ref
30          If WsC.Range("A3") = "" Then WsC.Rows(3).Delete
31          iLR = WsC.Cells(WsC.Rows.Count, 1).End(xlUp).Row
32          Arr = WsS.Range(WsS.Cells(3, 1), WsS.Cells(iMR, iLC)).Value          'Arr Source
33          Arc = WsC.Range(WsC.Cells(3, 1), WsC.Cells(iLR, iLC)).Value          'Arr Cible
34          For iiR = 1 To UBound(Arc)               'Pour chaque ligne de ArC (colonne 1)
35             For iC = 2 To iLC - 2 Step 4  'Pour chaque colonne de Arr (source)
36                For iR = 1 To UBound(Arr)          'On parcoure toutes les lignes pour trouver la même Référence
37                   If Trim(Arr(iR, iC)) = Arc(iiR, 1) Then
38                      Arc(iiR, iC) = Arc(iiR, 1)
39                      Arc(iiR, iC + 1) = Arr(iR, iC + 1)
40                      Arc(iiR, iC + 2) = Arr(iR, iC + 2)
41                   Exit For
42                   End If
43                Next
44             Next
45           Next
46          WsC.Range(WsC.Cells(3, 1), WsC.Cells(iLR, iLC)) = Arc 'une partie de l'affichage s'effectue avant le plantage
End Sub
 
Private Function KDic(S$) 'Pour insertion d'un caractère de tri primaire
Dim P$
Select Case Left(S, 1)
Case "#": P = ChrW(50)
Case "+": P = ChrW(51)
Case "_": P = ChrW(53)
Case "{": P = ChrW(54)
Case "}": P = ChrW(55)
Case "~": P = ChrW(56)
Case Else: P = ChrW(52)
End Select
KDic = P & Trim(S)
End Function
Et le fichier est disponible ici : (cjoint)
L'objet de la macro est d'aligner sur la même ligne les critères identiques.

Nota : A l'exécution la macro est relativement longue à s'exécuter avant de planter (peut-être un douzaine de secondes) mébon... C'est déjà un chouette petit tableau !

A défaut d'arriver à solutionner l'affichage si quelqu'un est capable d'expliquer le pourquoi du plantage, et fournir une piste pour contourner le problème, ça m'intéresserait.

Je ne pense pas que ce soit la taille de l'Array qui pose problème... J'en ai déjà chargé de plusieurs dizaine de milliers de lignes sans problème, donc je ne vois pas.

Merci.

A+