Discussion :

[Invité]

Bonjour Le Forum,

Je fais appel à vos compétences encore une fois pour un coup de main.

Voilà, il y a quelques temps "Mercatog" que je salue, m'avait proposé un code qui fonctionne très bien. Que je n'aurai jamais trouvé, même pas en rêve. Pour lequel il faut activer la bibliothèque " Microsoft Scripting Runtime".

Personnellement, ça ne me gênait pas d'avoir des chiffres alignés à droit avec le petit coin gauche du haut de la cellule en rouge. On me demande de résoudre ce problème.

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
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
Option Explicit
Sub Traitement()
Dim Lastlig As Long
Dim Tb, Tablo, Tp
Dim Ind As Byte
 
Application.ScreenUpdating = False
With Worksheets("BD")
    Lastlig = .Cells(.Rows.Count, 1).End(xlUp).Row
    Tb = .Range("A8:J" & Lastlig)
End With
 
Tp = Array("Beta", "Delta")
 
Application.DisplayAlerts = False
On Error Resume Next
Worksheets(Tp).Clear
On Error GoTo 0
Application.DisplayAlerts = False
 
For Ind = 0 To 1
    Tablo = Dispatch(Tb, Tp(Ind))
    With Worksheets(Tp(Ind))
        .Name = UCase(Tp(Ind))
        .Range("A1") = Tp(Ind)
        .Range("A7").Resize(UBound(Tablo, 1), UBound(Tablo, 2)) = Tablo
        .Range("A9").Resize(UBound(Tablo, 1) - 2, UBound(Tablo, 2)).Sort Key1:=.Range("A9"), order1:=xlAscending, Header:=xlNo
    End With
Next Ind
End Sub
 
'/!\ Active la référence Microsoft Scripting Runtime
Private Function Dispatch(ByVal Tb, ByVal Typ As String)
Dim Ouvrage As New Scripting.Dictionary
Dim PosteDirect As New Scripting.Dictionary
Dim C As Integer, m As Integer, R As Integer, n As Integer
Dim p As Integer, i As Integer, j As Integer, k As Integer
Dim Res(), Tmp, Vemp
 
p = UBound(Tb, 1)
For i = 1 To p
    If Tb(i, 2) = Typ Then
        Ouvrage(Tb(i, 3)) = ""
        PosteDirect(Tb(i, 4) & "|" & Tb(i, 9)) = ""
    End If
Next i
C = Ouvrage.Count
m = 5 + 2 * C
R = PosteDirect.Count
n = 2 + R
ReDim Res(1 To n, 1 To m)
 
Res(1, 1) = "N°"
Res(1, 2) = "Alim"
Res(1, 3) = "Alim"
Res(2, 2) = "(V)"
Res(2, 3) = "(A)"
For j = 0 To 2 * C - 1
    k = Int(j / 2)
    Res(1, j + 4) = Ouvrage.Keys(k)
    Res(2, 2 * k + 4) = "(mV)"
    Res(2, 2 * k + 5) = "(mA)"
Next j
Res(1, m - 1) = "Dire"
Res(1, m) = "Observations" ' (" & Typ & ")"
 
For i = 3 To n
    Vemp = Split(PosteDirect.Keys(i - 3), "|")
    Res(i, 1) = Vemp(0)
    For j = 4 To m - 2 Step 2
        k = Int((j - 4) / 2)
        Tmp = Sum(Tb, Typ, Vemp(1), Ouvrage.Keys(k), Res(i, 1))
        If Res(i, 2) = "" Then Res(i, 2) = Tmp(0)
        If Res(i, 3) = "" Then Res(i, 3) = Tmp(1)
        Res(i, j) = Tmp(2)
        Res(i, j + 1) = Tmp(3)
        Res(i, m) = Res(i, m) & "" & Tmp(5)
    Next j
    Res(i, m - 1) = Vemp(1)
Next i
 
Set Ouvrage = Nothing
Set PosteDirect = Nothing
Dispatch = Res
End Function
 
 
Private Function Sum(ByVal Tb, ByVal Typ As String, ByVal Dire As String, ByVal Ouv As String, ByVal Post As String)
Dim Tablo(0 To 5)
Dim i As Integer
Dim t As Byte
 
For i = 1 To UBound(Tb, 1)
    If Tb(i, 2) = Typ And Tb(i, 3) = Ouv And Tb(i, 4) = Post And Tb(i, 9) = Dire Then
        For t = 0 To 5
            Tablo(t) = Replace(Tb(i, 5 + t), Chr(10), " ")
        Next t
        Exit For
    End If
Next i
Sum = Tablo
End Function

J'ai essayé Val(Tmp(0)) et CDbl(Tmp(0)) et en destination j'ai des "0" (zéro).
Je pense que c'est au niveau de ce tableau que le transfert des 2 colonnes U et I s'effectue, à moins que je me trompe.

Là, je ne m'en sors plus. Je voudrais convertir les valeurs des colonnes U et I en numérique (afin que le petit rouge disparaisse).

Je vous remercie par avance.

Cordialement,

Il