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

O

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
vgendron
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) =...
Trier par date Trier par votes
vgendron

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
 
Vote positif 0 Vote négatif
O

onyirimba

XLDnaute Occasionnel
Supporter XLD
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
Cliquez pour agrandir...
Merci cela fonctionne parfaitement
 
Vote positif 0 Vote négatif
O

onyirimba

XLDnaute Occasionnel
Supporter XLD
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
Cliquez pour agrandir...
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
Vote positif 0 Vote négatif
O

onyirimba

XLDnaute Occasionnel
Supporter XLD
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
Cliquez pour agrandir...
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
Vote positif 0 Vote négatif
vgendron

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
Vote positif 0 Vote négatif
vgendron

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
 
Vote positif 0 Vote négatif
Solution
O

onyirimba

XLDnaute Occasionnel
Supporter XLD
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
Cliquez pour agrandir...
Bonjour,

Merci cela fonctionne
 
Vote positif 0 Vote négatif
Tomasisco21

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
Vote positif 0 Vote négatif
vgendron

vgendron

XLDnaute Barbatruc
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.
Cliquez pour agrandir...
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...
 
Vote positif 0 Vote négatif

Discussions similaires

cathodique
  • Résolu(e)
XL 2010 Module de classe avec Dictionary
3 4 5
Réponses
66
Affichages
3 K
patricktoulon
patricktoulon
E
  • Résolu(e)
Microsoft 365 Boucle sur lignes <>0
Réponses
2
Affichages
321
eric72
E
G
  • Question
Microsoft 365 Avoir des classeurs maitres et les procédures dans un autre classeur.
2
Réponses
18
Affichages
1 K
GClaire
G
cathodique
  • Question
XL 2010 Comment lire array dans item dictionnaire
2 3
Réponses
33
Affichages
2 K
cathodique
cathodique
T
  • Question
XL 2021 message si une valeur n'existe pas
Réponses
6
Affichages
650
target
T
T
  • Résolu(e)
XL 2021 Incompatibilité de type avec un userform
2
Réponses
19
Affichages
732
Bernard38
Bernard38
piga25
  • Résolu(e)
XL 2016 Erreur dans code VBA
4 5 6
Réponses
76
Affichages
2 K
patricktoulon
patricktoulon
G
  • Résolu(e)
XL 2021 VBA dates au mauvais format
Réponses
5
Affichages
250
vgendron
vgendron
O
  • Question
XL 2013 Créer un tableau par VBA selon des conditions
Réponses
1
Affichages
765
onyirimba
O
O
  • Résolu(e)
XL 2013 Rajouter une bordure noire dans un tableau par VBA
Réponses
5
Affichages
913
Lolote83
L

Membres actuellement en ligne

13 membres et 87 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
315 090
Messages
2 116 102
Membres
112 661
dernier inscrit
ceucri