XL 2013 Rajouter par VBA des lignes vides et des sommes dans un tableau

onyirimba · 25 Avril 2022

Bonjour,

J'ai programmé un code VBA qui permet de créer un tableau à partir d'une base de données cependant je souhaiterai rajouter des lignes vides (entre les RISK et OPPOR) et des sommes dans le tableau (dans la colonne RAF) mais je n'y arrive pas.

Est-ce que vous pouvez rajouter des lignes vides et des sommes en VBA dans mon codage pour que cela se rajoute dans mon tableau?

J'ai joint un fichier illustratif
Merci de votre aide

- VBA QUE J'AI PROGRAMME -

Option Explicit

Sub Extraire()
Dim Titre, dt As Integer, ws As Worksheet, cel As Range, n As Integer, dest As Range
Set ws = ThisWorkbook.Worksheets("Détail des risques")

With Sheets("BDGT")
For Each cel In .Range("A11:A" & .Range("A" & Rows.Count).End(xlUp).Row)

If cel.Offset(, 1) Like "*RISK*" Then
dt = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1

ws.Range("A" & dt) = cel.Offset(, 1)
ws.Range("B" & dt) = cel.Offset(, 2)
ws.Range("I" & dt) = cel.Offset(, 6)
End If

Next cel
End With

'''''''''''''''''''''''''''''''''''''''''''''''''''''''
With Sheets("BDGT")
For Each cel In .Range("A11:A" & .Range("A" & Rows.Count).End(xlUp).Row)

If cel.Offset(, 1) Like "*OPPOR*" Then

dt = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1

ws.Range("A" & dt) = cel.Offset(, 1)
ws.Range("B" & dt) = cel.Offset(, 2)
ws.Range("I" & dt) = cel.Offset(, 6)
End If

Next cel
End With

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''

End Sub

- RESULTAT SOUHAITE -

- RESULTAT QUE J'OBTIENS AVEC LA MACRO QUE J'AI PROGRAMME -

- ONGLET BDGT -

vgendron · 27 Avril 2022

Hello

si la colonne J = ColonneI.. je vois pas bien l'interêt d'avoir deux colonnes identiques..??
si j'ai bien compris ca donnerait ca:

VB:

Sub Extraire()
    Application.ScreenUpdating = False
    Dim Titre, dt As Integer, ws As Worksheet, cel As Range, n As Integer, dest As Range
    Dim Deb As Long
    Set ws = ThisWorkbook.Worksheets("Détail des risques")
    With ws
        .UsedRange.Offset(21, 0).Clear
    End With

    With Sheets("BDGT")
        For Each cel In .Range("A11:A" & .Range("A" & Rows.Count).End(xlUp).Row)
             If cel.Offset(, 1) Like "*RISK*" Then
                 dt = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1

                 ws.Range("A" & dt) = cel.Offset(, 1)
                 ws.Range("B" & dt) =...

vgendron · 25 Avril 2022

Bonjour
un test ci dessous

VB:

Sub Extraire()
    Dim Titre, dt As Integer, ws As Worksheet, cel As Range, n As Integer, dest As Range
    Dim Deb As Long
    Set ws = ThisWorkbook.Worksheets("Détail des risques")
    With ws
        .UsedRange.Offset(21, 0).Clear
    End With

    With Sheets("BDGT")
        For Each cel In .Range("A11:A" & .Range("A" & Rows.Count).End(xlUp).Row)

             If cel.Offset(, 1) Like "*RISK*" Then
                 dt = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1

                 ws.Range("A" & dt) = cel.Offset(, 1)
                 ws.Range("B" & dt) = cel.Offset(, 2)
                 ws.Range("I" & dt) = cel.Offset(, 6)
             End If

        Next cel
        
    End With
    With ws
        .Range("A" & dt + 1) = "Total"
        .Range("I" & dt + 1).Formula = "=sum(I22:I" & dt & ")"
    End With
    dt = dt + 4 '+4 à ajuster selon le nombre de lignes à insérer
    Deb = dt 'sauvegarde de la première ligne pour les OPPORT
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
    With Sheets("BDGT")
        For Each cel In .Range("A11:A" & .Range("A" & Rows.Count).End(xlUp).Row)

             If cel.Offset(, 1) Like "*OPPOR*" Then
 
                 'dt = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1

                 ws.Range("A" & dt) = cel.Offset(, 1)
                 ws.Range("B" & dt) = cel.Offset(, 2)
                 ws.Range("I" & dt) = cel.Offset(, 6)
                 dt = dt + 1
             End If

        Next cel
    End With
    With ws
        .Range("A" & dt) = "Total"
        .Range("I" & dt).Formula = "=sum(I" & Deb & ":I" & dt & ")"
    End With

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''

End Sub

onyirimba · 25 Avril 2022

vgendron à dit:

Bonjour
un test ci dessous

VB:

Sub Extraire()
    Dim Titre, dt As Integer, ws As Worksheet, cel As Range, n As Integer, dest As Range
    Dim Deb As Long
    Set ws = ThisWorkbook.Worksheets("Détail des risques")
    With ws
        .UsedRange.Offset(21, 0).Clear
    End With

    With Sheets("BDGT")
        For Each cel In .Range("A11:A" & .Range("A" & Rows.Count).End(xlUp).Row)

             If cel.Offset(, 1) Like "*RISK*" Then
                 dt = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1

                 ws.Range("A" & dt) = cel.Offset(, 1)
                 ws.Range("B" & dt) = cel.Offset(, 2)
                 ws.Range("I" & dt) = cel.Offset(, 6)
             End If

        Next cel
       
    End With
    With ws
        .Range("A" & dt + 1) = "Total"
        .Range("I" & dt + 1).Formula = "=sum(I22:I" & dt & ")"
    End With
    dt = dt + 4 '+4 à ajuster selon le nombre de lignes à insérer
    Deb = dt 'sauvegarde de la première ligne pour les OPPORT
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
    With Sheets("BDGT")
        For Each cel In .Range("A11:A" & .Range("A" & Rows.Count).End(xlUp).Row)

             If cel.Offset(, 1) Like "*OPPOR*" Then
 
                 'dt = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1

                 ws.Range("A" & dt) = cel.Offset(, 1)
                 ws.Range("B" & dt) = cel.Offset(, 2)
                 ws.Range("I" & dt) = cel.Offset(, 6)
                 dt = dt + 1
             End If

        Next cel
    End With
    With ws
        .Range("A" & dt) = "Total"
        .Range("I" & dt).Formula = "=sum(I" & Deb & ":I" & dt & ")"
    End With

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''

End Sub

Merci cela fonctionne parfaitement

onyirimba · 25 Avril 2022

vgendron à dit:

Bonjour
un test ci dessous

VB:

Sub Extraire()
    Dim Titre, dt As Integer, ws As Worksheet, cel As Range, n As Integer, dest As Range
    Dim Deb As Long
    Set ws = ThisWorkbook.Worksheets("Détail des risques")
    With ws
        .UsedRange.Offset(21, 0).Clear
    End With

    With Sheets("BDGT")
        For Each cel In .Range("A11:A" & .Range("A" & Rows.Count).End(xlUp).Row)

             If cel.Offset(, 1) Like "*RISK*" Then
                 dt = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1

                 ws.Range("A" & dt) = cel.Offset(, 1)
                 ws.Range("B" & dt) = cel.Offset(, 2)
                 ws.Range("I" & dt) = cel.Offset(, 6)
             End If

        Next cel
      
    End With
    With ws
        .Range("A" & dt + 1) = "Total"
        .Range("I" & dt + 1).Formula = "=sum(I22:I" & dt & ")"
    End With
    dt = dt + 4 '+4 à ajuster selon le nombre de lignes à insérer
    Deb = dt 'sauvegarde de la première ligne pour les OPPORT
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
    With Sheets("BDGT")
        For Each cel In .Range("A11:A" & .Range("A" & Rows.Count).End(xlUp).Row)

             If cel.Offset(, 1) Like "*OPPOR*" Then
 
                 'dt = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1

                 ws.Range("A" & dt) = cel.Offset(, 1)
                 ws.Range("B" & dt) = cel.Offset(, 2)
                 ws.Range("I" & dt) = cel.Offset(, 6)
                 dt = dt + 1
             End If

        Next cel
    End With
    With ws
        .Range("A" & dt) = "Total"
        .Range("I" & dt).Formula = "=sum(I" & Deb & ":I" & dt & ")"
    End With

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''

End Sub

Bonjour,

est-ce que vous pouvez rajouter la mise en page ci dessous par programmation VBA dans les 2 tableaux crées ?

J'ai joint un fichier illustratif

Merci beaucoup

onyirimba · 25 Avril 2022

vgendron à dit:

Bonjour
un test ci dessous

VB:

Sub Extraire()
    Dim Titre, dt As Integer, ws As Worksheet, cel As Range, n As Integer, dest As Range
    Dim Deb As Long
    Set ws = ThisWorkbook.Worksheets("Détail des risques")
    With ws
        .UsedRange.Offset(21, 0).Clear
    End With

    With Sheets("BDGT")
        For Each cel In .Range("A11:A" & .Range("A" & Rows.Count).End(xlUp).Row)

             If cel.Offset(, 1) Like "*RISK*" Then
                 dt = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1

                 ws.Range("A" & dt) = cel.Offset(, 1)
                 ws.Range("B" & dt) = cel.Offset(, 2)
                 ws.Range("I" & dt) = cel.Offset(, 6)
             End If

        Next cel
       
    End With
    With ws
        .Range("A" & dt + 1) = "Total"
        .Range("I" & dt + 1).Formula = "=sum(I22:I" & dt & ")"
    End With
    dt = dt + 4 '+4 à ajuster selon le nombre de lignes à insérer
    Deb = dt 'sauvegarde de la première ligne pour les OPPORT
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
    With Sheets("BDGT")
        For Each cel In .Range("A11:A" & .Range("A" & Rows.Count).End(xlUp).Row)

             If cel.Offset(, 1) Like "*OPPOR*" Then
 
                 'dt = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1

                 ws.Range("A" & dt) = cel.Offset(, 1)
                 ws.Range("B" & dt) = cel.Offset(, 2)
                 ws.Range("I" & dt) = cel.Offset(, 6)
                 dt = dt + 1
             End If

        Next cel
    End With
    With ws
        .Range("A" & dt) = "Total"
        .Range("I" & dt).Formula = "=sum(I" & Deb & ":I" & dt & ")"
    End With

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''

End Sub

J'ai rajouté un onglet MODELE avec le modèle de la mise en page à réaliser dans l'onglet " Détail des risques "

vgendron · 25 Avril 2022

Hello
voir PJ
j'ai modifié ta feuille "Modèle" pour ne garder que les lignes utiles

Note: la ligne d'entete n'étant pas effacée dans la feuille de résultat, la Mise en forme n'est pas (et n'a pas besoin de) recopiée

onyirimba · 25 Avril 2022

vgendron à dit:
Hello
voir PJ
j'ai modifié ta feuille "Modèle" pour ne garder que les lignes utiles

Note: la ligne d'entete n'étant pas effacée dans la feuille de résultat, la Mise en forme n'est pas (et n'a pas besoin de) recopiée

Salut,

Je te remercie.... Cela fonctionne parfaitement

onyirimba · 27 Avril 2022

Salut,

est-ce que tu peux rajouter le fait que les cellules J soient égales aux cellules I correspondante (comme si dessous) ?
ex : J22 = I22, J23 = I23, J28=I28....

Merci beaucoup

vgendron · 27 Avril 2022

Hello

si la colonne J = ColonneI.. je vois pas bien l'interêt d'avoir deux colonnes identiques..??
si j'ai bien compris ca donnerait ca:

VB:

Sub Extraire()
    Application.ScreenUpdating = False
    Dim Titre, dt As Integer, ws As Worksheet, cel As Range, n As Integer, dest As Range
    Dim Deb As Long
    Set ws = ThisWorkbook.Worksheets("Détail des risques")
    With ws
        .UsedRange.Offset(21, 0).Clear
    End With

    With Sheets("BDGT")
        For Each cel In .Range("A11:A" & .Range("A" & Rows.Count).End(xlUp).Row)
             If cel.Offset(, 1) Like "*RISK*" Then
                 dt = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1

                 ws.Range("A" & dt) = cel.Offset(, 1)
                 ws.Range("B" & dt) = cel.Offset(, 2)
                 ws.Range("I" & dt) = cel.Offset(, 6)
                 ws.Range("J" & dt) = ws.Range("I" & dt)
             End If
        Next cel
    End With
    With ws
        .Range("A" & dt + 1) = "Total"
        .Range("I" & dt + 1).Formula = "=sum(I22:I" & dt & ")"
    End With
    dt = dt + 4 '+4 à ajuster selon le nombre de lignes à insérer
    Deb = dt 'sauvegarde de la première ligne pour les OPPOR
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
    With Sheets("BDGT")
        For Each cel In .Range("A11:A" & .Range("A" & Rows.Count).End(xlUp).Row)

             If cel.Offset(, 1) Like "*OPPOR*" Then
                 ws.Range("A" & dt) = cel.Offset(, 1)
                 ws.Range("B" & dt) = cel.Offset(, 2)
                 ws.Range("I" & dt) = cel.Offset(, 6)
                 ws.Range("J" & dt) = ws.Range("I" & dt)
                 dt = dt + 1
             End If
        Next cel
    End With
    With ws
        .Range("A" & dt) = "Total"
        .Range("I" & dt).Formula = "=sum(I" & Deb & ":I" & dt - 1 & ")"
    End With

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Sheets("MODELE").Rows("2:2").Copy
    With ws
        For i = 22 To dt
            If .Range("A" & i) <> "Total" And .Range("A" & i) <> "" Then
                .Rows(i).PasteSpecial Paste:=xlPasteFormats, operation:=xlNone, skipblanks:=False, Transpose:=False
            End If
        Next i
    End With
    
    Sheets("MODELE").Rows("3:3").Copy
    With ws
        For i = 22 To dt
            If .Range("A" & i) = "Total" Then
                .Rows(i).PasteSpecial Paste:=xlPasteFormats, operation:=xlNone, skipblanks:=False, Transpose:=False
            End If
        Next i
    End With
    Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

onyirimba · 27 Avril 2022

Hello
Merci je regarde

onyirimba · 28 Avril 2022

vgendron à dit:

Hello

si la colonne J = ColonneI.. je vois pas bien l'interêt d'avoir deux colonnes identiques..??
si j'ai bien compris ca donnerait ca:

VB:

Sub Extraire()
    Application.ScreenUpdating = False
    Dim Titre, dt As Integer, ws As Worksheet, cel As Range, n As Integer, dest As Range
    Dim Deb As Long
    Set ws = ThisWorkbook.Worksheets("Détail des risques")
    With ws
        .UsedRange.Offset(21, 0).Clear
    End With

    With Sheets("BDGT")
        For Each cel In .Range("A11:A" & .Range("A" & Rows.Count).End(xlUp).Row)
             If cel.Offset(, 1) Like "*RISK*" Then
                 dt = ws.Cells(Rows.Count, 1).End(xlUp).Row + 1

                 ws.Range("A" & dt) = cel.Offset(, 1)
                 ws.Range("B" & dt) = cel.Offset(, 2)
                 ws.Range("I" & dt) = cel.Offset(, 6)
                 ws.Range("J" & dt) = ws.Range("I" & dt)
             End If
        Next cel
    End With
    With ws
        .Range("A" & dt + 1) = "Total"
        .Range("I" & dt + 1).Formula = "=sum(I22:I" & dt & ")"
    End With
    dt = dt + 4 '+4 à ajuster selon le nombre de lignes à insérer
    Deb = dt 'sauvegarde de la première ligne pour les OPPOR
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
    With Sheets("BDGT")
        For Each cel In .Range("A11:A" & .Range("A" & Rows.Count).End(xlUp).Row)

             If cel.Offset(, 1) Like "*OPPOR*" Then
                 ws.Range("A" & dt) = cel.Offset(, 1)
                 ws.Range("B" & dt) = cel.Offset(, 2)
                 ws.Range("I" & dt) = cel.Offset(, 6)
                 ws.Range("J" & dt) = ws.Range("I" & dt)
                 dt = dt + 1
             End If
        Next cel
    End With
    With ws
        .Range("A" & dt) = "Total"
        .Range("I" & dt).Formula = "=sum(I" & Deb & ":I" & dt - 1 & ")"
    End With

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Sheets("MODELE").Rows("2:2").Copy
    With ws
        For i = 22 To dt
            If .Range("A" & i) <> "Total" And .Range("A" & i) <> "" Then
                .Rows(i).PasteSpecial Paste:=xlPasteFormats, operation:=xlNone, skipblanks:=False, Transpose:=False
            End If
        Next i
    End With
   
    Sheets("MODELE").Rows("3:3").Copy
    With ws
        For i = 22 To dt
            If .Range("A" & i) = "Total" Then
                .Rows(i).PasteSpecial Paste:=xlPasteFormats, operation:=xlNone, skipblanks:=False, Transpose:=False
            End If
        Next i
    End With
    Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Bonjour,

Merci cela fonctionne

Tomasisco21 · 28 Avril 2022

Bonjour à tous,

Tout d'abord je voudrai vous remercier pour l'aide que vous proposez en ligne,

J'ai un soucis avec macro actuel,
Ne maîtrosant pas bien le VBA,
j'aimerais avoir des insertions de ligne automatique sur chacun de mes tableaux suivant les conditions de mon fichier ci-joint.

J'espère que ma demande est compréhensible. Si ce n'est pas le cas, je m'en excuse d'avance.
Et si quelqu'un aurait une piste, je le remercie d'avance.

vgendron · 28 Avril 2022

Ndenga Thomas à dit:
Bonjour à tous,

Tout d'abord je voudrai vous remercier pour l'aide que vous proposez en ligne,
J'ai un soucis avec macro actuel,
Ne maîtrosant pas bien le VBA,
j'aimerais avoir des insertions de ligne automatique sur chacun de mes tableaux suivant les conditions de mon fichier ci-joint.

J'espère que ma demande est compréhensible. Si ce n'est pas le cas, je m'en excuse d'avance.
Et si quelqu'un aurait une piste, je le remercie d'avance.

Bonjour
Commence par créer ton propre post
ici, c'est comme si tu voyais des gens dans la rue en train de discuter,, et toi tu te pointes pour parler d'autre chose...

XL 2013 Rajouter par VBA des lignes vides et des sommes dans un tableau

onyirimba

XLDnaute Occasionnel

Pièces jointes

vgendron

vgendron

XLDnaute Barbatruc

onyirimba

XLDnaute Occasionnel

onyirimba

XLDnaute Occasionnel

Pièces jointes

onyirimba

XLDnaute Occasionnel

Pièces jointes

vgendron

XLDnaute Barbatruc

Pièces jointes

onyirimba

XLDnaute Occasionnel

onyirimba

XLDnaute Occasionnel

Pièces jointes

vgendron

XLDnaute Barbatruc

onyirimba

XLDnaute Occasionnel

onyirimba

XLDnaute Occasionnel

Tomasisco21

XLDnaute Nouveau

Pièces jointes

vgendron

XLDnaute Barbatruc

Discussions similaires

XL 2013 Rajouter par VBA des lignes vides et des sommes dans un tableau

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Occasionnel

Pièces jointes

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Occasionnel

XLDnaute Nouveau

Pièces jointes

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency