Discussion :

[Kiveudesprunos]

Bonsoir à tous,

Je galère depuis quelques temps pour extraire des chaines de caractères d'une cellule excel et recopie de valeurs liées à ces chaines de caractères par le biais de formules..
Force est de constaté qu'il va falloir puiser dans le VBA pour m'en sortir. Quelqu'un aurait il une idée sur la façon de procéder ? merci d'avance

[joe.levrai]

Bonjour,

ceci fonctionne sur le fichier que tu nous montres

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
Sub Comptabilisation()
 
Dim Ligne As Long
Dim Colonne As Long
Dim Position As Long
 
With ThisWorkbook.Worksheets("Feuil1")
    ' dernière ligne
    Ligne = .Cells(Rows.Count, 1).End(xlUp).Row
    ' dernière colonne
    Colonne = .Cells(1, Columns.Count).End(xlToLeft).Column
 
    ' parcours les lignes
    For Ligne = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
        ' parcours les colonnes
        For Colonne = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column
            ' cherche le DKxxx dans la ligne
            If .Cells(Ligne, 1) Like "*" & .Cells(1, Colonne) & "*" Then
                'position de la fin du DLKxxx dans la ligne
                Position = InStr(1, .Cells(Ligne, 1), .Cells(1, Colonne)) + 3
                ' écriture du résultat, en identifiant la virgule dans le chiffre
                .Cells(Ligne, Colonne) = CDbl(Mid(.Cells(Ligne, 1), Position + 3, InStr(Position, .Cells(Ligne, 1), ",") - Position))
            End If
        Next Colonne
    Next Ligne
End With
 
End Sub

[gnain]

Bonjour,
Bonne méthode joe.levrai
mais tu as oublier d'additionner si il y en à 2 de pareils comme demandé.

voici une autre méthode

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
Sub recherche_DLK()
    Range("B2:AL20").ClearContents
    Range("B2:AL20").NumberFormat = "0.00"
    For k = 2 To Range("A" & Rows.Count).End(xlUp).Row
        Dim WrdArray() As String
        WrdArray() = Split(Cells(k, 1), "DLK")
 
        For i = LBound(WrdArray) To UBound(WrdArray)
            If i > 0 Then
                For j = 2 To 38
                    If Left(Cells(1, j).Value, 5) = "DLK" & Left(WrdArray(i), 2) Then
                        Cells(k, j).Value = Cells(k, j).Value + Replace(Mid(WrdArray(i), 4, 4), ",", ".")
                    End If
                Next
            End If
        Next i
    Next k
End Sub

[Kiveudesprunos]

Qu’elle rapidité... la macro de joe fonctionne sans additionner , c’est déja un premier pas et la tienne Gnain me demande de déterminer la variable ! Erreur de compilation sur la boucle For k = 2 ,ce qui pour moi est littéralement du Mandarin puisque je débute à peine en Vba je m’y suis mis hier soir...
En tout cas c’est sympa d’avoir répondu à ma sollicitation.

[gnain]

Bonjour,

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
Sub recherche_DLK()
    Dim k As Long
    Dim i As Integer
    Dim j As Integer
    Range("B2:AL20").ClearContents
    Range("B2:AL20").NumberFormat = "0.00"
    For k = 2 To Range("A" & Rows.Count).End(xlUp).Row
        Dim WrdArray() As String
        WrdArray() = Split(Cells(k, 1), "DLK")
 
        For i = LBound(WrdArray) To UBound(WrdArray)
            If i > 0 Then
                For j = 2 To 38
                    If Left(Cells(1, j).Value, 5) = "DLK" & Left(WrdArray(i), 2) Then
                        Cells(k, j).Value = Cells(k, j).Value + Replace(Mid(WrdArray(i), 4, 4), ",", ".")
                    End If
                Next
            End If
        Next i
    Next k
End Sub

[joe.levrai]

Bonjour,

merci gnain pour la remarque, j'avais pas vu les doublons

ceci semble corriger ma bêtise

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
Sub Comptabilisation()
 
Dim Ligne As Long
Dim Colonne As Long
Dim Position As Long
 
With ThisWorkbook.Worksheets("Feuil1")
    For Ligne = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
        For Colonne = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column
            Position = 1
            If .Cells(Ligne, 1) Like "*" & .Cells(1, Colonne) & "*" Then
                Do
                    Position = InStr(Position, .Cells(Ligne, 1), .Cells(1, Colonne)) + 3
                    If Position = 3 Then Exit Do
                    .Cells(Ligne, Colonne) = .Cells(Ligne, Colonne) + CDbl(Mid(.Cells(Ligne, 1), Position + 3, InStr(Position, .Cells(Ligne, 1), ",") - Position))
                Loop
            End If
        Next Colonne
    Next Ligne
End With
 
End Sub