Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

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 -




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


- ONGLET BDGT -
 

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

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
Merci cela fonctionne parfaitement
 
Vote positif 0 Vote négatif
O

onyirimba

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

Pièces jointes

  • VBA lignes vides.xlsm
    45.9 KB · Affichages: 1
Vote positif 0 Vote négatif
O

onyirimba

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

 

Pièces jointes

  • VBA lignes vides.xlsm
    47.7 KB · Affichages: 2
Vote positif 0 Vote négatif

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

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

Merci cela fonctionne
 
Vote positif 0 Vote négatif

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

XLDnaute Barbatruc
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
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

  • Résolu(e)
XL 2010 Module de classe avec Dictionary
3 4 5
Réponses
66
Affichages
3 K
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
  • Question
XL 2010 Comment lire array dans item dictionnaire
2 3
Réponses
33
Affichages
2 K
cathodique
T
  • Question
XL 2021 message si une valeur n'existe pas
Réponses
6
Affichages
652
target
T
T
  • Résolu(e)
XL 2021 Incompatibilité de type avec un userform
2
Réponses
19
Affichages
732
Bernard38
  • Résolu(e)
XL 2016 Erreur dans code VBA
4 5 6
Réponses
76
Affichages
2 K
patricktoulon
G
  • Résolu(e)
XL 2021 VBA dates au mauvais format
Réponses
5
Affichages
250
vgendron
O
  • Question
XL 2013 Créer un tableau par VBA selon des conditions
Réponses
1
Affichages
766
onyirimba
O
O
  • Résolu(e)
XL 2013 Rajouter une bordure noire dans un tableau par VBA
Réponses
5
Affichages
913
Lolote83
L
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…