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

[Docmarti]

Bonjour cathodique.

Il faut typer les valeurs en type DOUBLE dans le tableau RES.

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
        If Res(i, 2) = "" Then Res(i, 2) = CheckType(Tmp(0))
        If Res(i, 3) = "" Then Res(i, 3) = CheckType(Tmp(1))
        Res(i, j) = CheckType(Tmp(2))
        Res(i, j + 1) = CheckType(Tmp(3))
 
Function CheckType(valeur)
 
 If IsNumeric(valeur) Then
  CheckType = CDbl(valeur)
  Else
   CheckType = valeur
 End If
 
 End Function

[Invité]

Bonsoir Docmarti,

Je te remercie beaucoup. Honnêtement, je n'aurai jamais trouvé tout seul.

Ton code fonctionne bien, mais les cellules vides de la feuille source sont remplacées par des zéros sur les feuilles de destination BETA et DELTA.

Je pourrais passer par les options d'Excel pour ne pas afficher les valeurs nulles.

Mais n'y aurait-il pas moyen de gérer ceci par VBA?

Je te remercie beaucoup.

Cordialement,

Re,

j'ai été trop rapide dans mon test. je n'avais vérifié le résultat que pour la feuille DELTA, pour laquelle les données sont bonnes.
Par contre pour la feuille BETA les résultats ne sont pas bons (des zéros sont mis dans des cellules dont les valeurs de la feuille source ne sont pas vides).
Donc le résultat de cette feuille est erroné.

Merci beaucoup.

Cordialement,

Re,

Mon souci réside sur les colonnes B et C des feuilles de destination (BETA et DELTA). ça ne me gênerai pas de faire appel à une macro pour ne traiter que ces colonnes. je pensais à récupérer les valeurs des colonnes B et C dans un tableau puis de le multiplier par 1 et le remettre (comme pour faire un collage spécial et sélectionner l’opération multiplication). Problème, je suis nul en tableau.

Est-ce une bonne solution?

Cordialement,

[Docmarti]

Bonsoir Docmarti,

Je te remercie beaucoup. Honnêtement, je n'aurai jamais trouvé tout seul.

Ton code fonctionne bien, mais les cellules vides de la feuille source sont remplacées par des zéros sur les feuilles de destination BETA et DELTA.

Je pourrais passer par les options d'Excel pour ne pas afficher les valeurs nulles.

Mais n'y aurait-il pas moyen de gérer ceci par VBA?

Je te remercie beaucoup.

Cordialement,

Il faut adapter la fonction CheckType selon tes besoins et faire des tests :

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
Function CheckType(valeur)
 
  CheckType = valeur
 
 If Trim(valeur) = "" Then
  Exit Function
 End If
 
  If IsNumeric(valeur) Then
   CheckType = CDbl(valeur)
 
  ElseIf IsDate(valeur) Then
   CheckType = CDate(DateValue(valeur) & " " & TimeValue(valeur))
 
  Else
   Stop
 
 End If
 
 End Function

Je vais y jeter encore un coup d'oeil.

La dernière fonction me semble donner les résultats attendus.

[Invité]

Bonjour Docmarti,

Je te suis reconnaissant, ça fonctionne très bien. Ta dernière fonction donne le résultat escompté. Je te remercie beaucoup.

Je te souhaite une très bonne journée.

Cordialement,