Fusionner la table

Version imprimable

17/10/2019, 04h55
alidroos

1 pièce(s) jointe(s)

Fusionner la table

Bonjour les experts Codes vba

Je veux supprimer des lignes de tableau avec des cellules de texte fusionnées et calculer des cellules numériques

Tableau A Avant la mise en œuvre

Tableau B Après suppression et combinaison

l'image jointe

Pièce jointe 510467

Merci d'avance

Bonjour,

Ceci

Code:

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
Sub Fusionner_la_table()
    Dim DerLig As Long, Lig_TabB As Long
    Dim d As String, Valeur As String, Da As String
    Application.ScreenUpdating = False
    Range("G2:I" & [G2].End(xlDown).Row).ClearContents
    DerLig = Range("C" & Rows.Count).End(xlUp).Row
    Lig_TabB = 2
    Da = 0
    d = ""
    Valeur = ""
    For i = 2 To DerLig + 1
        If Cells(i, "C") = "" Then
                Cells(Lig_TabB, "G") = Da
                Cells(Lig_TabB, "H") = d
                Cells(Lig_TabB, "I") = Valeur
                Da = 0
                d = ""
                Valeur = ""
                Lig_TabB = Lig_TabB + 1
        ElseIf Lig_TabB <> 2 Then
            If Cells(i, "D") <> Cells(i + 1, "D") And Cells(i + 1, "D") <> "" Then
                If IsNumeric(Cells(i, "C")) Then Da = CInt(Da) + Cells(i, "C") Else Da = Da & " " & Cells(i, "C")
                If Left(Da, 2) = "0 " Then Da = Right(Da, Len(Da) - 2)
                Cells(Lig_TabB, "G") = Da
                Cells(Lig_TabB, "H") = d
                Cells(Lig_TabB, "I") = Valeur
                Da = 0
                d = ""
                Valeur = ""
                Lig_TabB = Lig_TabB + 1
            Else
                If IsNumeric(Cells(i, "C")) Then Da = Da + Cells(i, "C") Else Da = Da & " " & Cells(i, "C")
                If Cells(i, "D") <> "" Then
                    d = Cells(i, "D")
                    Valeur = Cells(i, "E")
                End If
            End If
        ElseIf Lig_TabB = 2 Then
            If i <> 2 And Cells(i, "D") <> Cells(i + 1, "D") Then
                If Left(Da, 2) = "0 " Then Da = Right(Da, Len(Da) - 2)
                Cells(Lig_TabB, "G") = Da
                Cells(Lig_TabB, "H") = d
                Cells(Lig_TabB, "I") = Valeur
                Da = 0
                d = ""
                Valeur = ""
                Lig_TabB = Lig_TabB + 1
            Else
                If IsNumeric(Cells(i, "C")) Then Da = Da + Cells(i, "C") Else Da = Da & " " & Cells(i, "C")
                If Cells(i, "D") <> "" Then
                    d = Cells(i, "D")
                    Valeur = Cells(i, "E")
                End If
            End If
        End If
    Next i
End Sub

Le fichier
Pièce jointe 511138

Cdlt

20/10/2019, 18h27
alidroos

Merci Professeur ARTURO83
21/10/2019, 03h37
alidroos

1 pièce(s) jointe(s)

Professeur ARTURO83
La première table d'instructions n'a pas été fusionnée

Pièce jointe 511391

Bonjour,

Petit oubli réparé
le fichier
Pièce jointe 511397

le code

Code:

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
Sub Fusionner_la_table()
    Dim DerLig As Long, Lig_TabB As Long
    Dim d As String, Valeur As String, Da As String
    Application.ScreenUpdating = False
    Range("G2:I" & [G2].End(xlDown).Row).ClearContents
    DerLig = Range("C" & Rows.Count).End(xlUp).Row
    Lig_TabB = 2
    Da = 0
    d = ""
    Valeur = ""
    For i = 2 To DerLig + 1
        If Cells(i, "C") = "" Then
                If Left(Da, 2) = "0 " Then Da = Right(Da, Len(Da) - 2)
                Cells(Lig_TabB, "G") = Da
                Cells(Lig_TabB, "H") = d
                Cells(Lig_TabB, "I") = Valeur
                Da = 0
                d = ""
                Valeur = ""
                Lig_TabB = Lig_TabB + 1
        ElseIf Lig_TabB <> 2 Then
            If Cells(i, "D") <> Cells(i + 1, "D") And Cells(i + 1, "D") <> "" Then
                If IsNumeric(Cells(i, "C")) Then Da = CInt(Da) + Cells(i, "C") Else Da = Da & " " & Cells(i, "C")
                If Left(Da, 2) = "0 " Then Da = Right(Da, Len(Da) - 2)
                Cells(Lig_TabB, "G") = Da
                Cells(Lig_TabB, "H") = d
                Cells(Lig_TabB, "I") = Valeur
                Da = 0
                d = ""
                Valeur = ""
                Lig_TabB = Lig_TabB + 1
            Else
                If IsNumeric(Cells(i, "C")) Then Da = Da + Cells(i, "C") Else Da = Da & " " & Cells(i, "C")
                If Cells(i, "D") <> "" Then
                    d = Cells(i, "D")
                    Valeur = Cells(i, "E")
                End If
            End If
        ElseIf Lig_TabB = 2 Then
            If i <> 2 And Cells(i, "D") <> Cells(i + 1, "D") Then
                If IsNumeric(Cells(i, "C")) Then Da = Da + Cells(i, "C") Else Da = Da & " " & Cells(i, "C")
                If Left(Da, 2) = "0 " Then Da = Right(Da, Len(Da) - 2)
                Cells(Lig_TabB, "G") = Da
                Cells(Lig_TabB, "H") = d
                Cells(Lig_TabB, "I") = Valeur
                Da = 0
                d = ""
                Valeur = ""
                Lig_TabB = Lig_TabB + 1
            Else
                If IsNumeric(Cells(i, "C")) Then Da = Da + Cells(i, "C") Else Da = Da & " " & Cells(i, "C")
                If Cells(i, "D") <> "" Then
                    d = Cells(i, "D")
                    Valeur = Cells(i, "E")
                End If
            End If
        End If
    Next i
End Sub

Cdlt