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

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion onyirimba
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
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

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

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

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

Vote positif 0 Vote négatif
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
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

E
  • Résolu(e)
Microsoft 365 Boucle sur lignes <>0
Réponses
2
Affichages
340
eric72
E
S
  • Résolu(e)
XL 2016 Coller nom classeur sur plage cellules
Réponses
9
Affichages
93
safranien
S
K
  • Résolu(e)
XL 2016 Affichage TextBox
Réponses
6
Affichages
85
KRUG WOO
K
M
  • Question Question
XL 2013 MACRO VBA pour imprimer tous les bulletins d'un établissement scolaire
Réponses
4
Affichages
296
MBEPID
M
G
  • Question Question
Microsoft 365 Avoir des classeurs maitres et les procédures dans un autre classeur.
2
Réponses
18
Affichages
1 K
GClaire
G
T
  • Question Question
XL 2021 message si une valeur n'existe pas
Réponses
6
Affichages
692
target
T
piga25
  • Résolu(e)
XL 2016 Erreur dans code VBA
4 5 6
Réponses
76
Affichages
2 K
patricktoulon
patricktoulon
F
  • Question Question
Microsoft 365 aide VBA excel
Réponses
4
Affichages
355
Oneida
Oneida
N
  • Résolu(e)
XL 2021 comment faire recherche dans une colonne et ligne
Réponses
5
Affichages
429
job75
job75
G
  • Résolu(e)
XL 2021 VBA dates au mauvais format
Réponses
5
Affichages
311
vgendron
vgendron
piga25
  • Résolu(e)
XL 2016 En VBA, Automatiser la réponse en fonction de l'état d'une cellule.
Réponses
7
Affichages
64
piga25
piga25
S
  • Question Question
XL 2021 macro VBA excel
Réponses
1
Affichages
465
crocrocro
C
O
  • Résolu(e)
XL 2013 Rajouter une bordure noire dans un tableau par VBA
Réponses
5
Affichages
943
Lolote83
L
O
  • Question Question
XL 2013 Créer un tableau par VBA selon des conditions
Réponses
1
Affichages
779
onyirimba
O
halecs93
  • Question Question
XL 2016 Masquer et afficher lignes
Réponses
3
Affichages
414
gbinforme
G
S
  • Résolu(e)
Microsoft 365 VBA Concaténer contenu de plusieurs cellules dans une seule avec séparateurs / évolutifs
Réponses
3
Affichages
95
spike29
S
T
  • Résolu(e)
Microsoft 365 Insérer une image DANS une cellule
Réponses
12
Affichages
796
Thomi
T
A
  • Question Question
insertion d'une ligne automatique dans un tableau excel.
Réponses
1
Affichages
330
sylvanu
sylvanu
B
  • Résolu(e)
Microsoft 365 creation d'liste à imprimer
2 3 4
Réponses
51
Affichages
1 K
Banbara
B
A
  • Question Question
Microsoft 365 Code VBA Envoi contenu tableau Excel par Email
Réponses
1
Affichages
434
Phil69970
Phil69970
Retour