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

onyirimba

XLDnaute Occasionnel
Supporter XLD
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 -
1650873917648.png




- RESULTAT QUE J'OBTIENS AVEC LA MACRO QUE J'AI PROGRAMME -
1650873510846.png


- ONGLET BDGT -
1650873541864.png
 

Pièces jointes

  • VBA lignes vides.xlsm
    44.5 KB · Affichages: 5
Dernière édition:
Solution
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

XLDnaute Barbatruc
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

XLDnaute Occasionnel
Supporter XLD
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

XLDnaute Occasionnel
Supporter XLD
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
1650878051124.png
 

Pièces jointes

  • VBA lignes vides.xlsm
    45.9 KB · Affichages: 1

onyirimba

XLDnaute Occasionnel
Supporter XLD
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 "

1650882567725.png
 

Pièces jointes

  • VBA lignes vides.xlsm
    47.7 KB · Affichages: 2

vgendron

XLDnaute Barbatruc
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
 

Pièces jointes

  • VBA lignes vides (1).xlsm
    52.7 KB · Affichages: 3

vgendron

XLDnaute Barbatruc
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

XLDnaute Occasionnel
Supporter XLD
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

XLDnaute Nouveau
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.
 

Pièces jointes

  • SUIVI STOCKS MAGASIN ESTIA CMR.xlsm
    178.7 KB · Affichages: 2

vgendron

XLDnaute Barbatruc
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...
 

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 899
Membres
101 834
dernier inscrit
Jeremy06510