VBA : Copier une ligne d'une feuille a une autre sous condition

Le 13/08/2018 à 17:36

Bonjour,

Je débute en VBA et j'aurais souhaité effectuer l'opération suivante avec une macro sous Excel 2013 :

Pour chaque cellule de la colonne G de la feuille 2 :

Dans un premier temps, on colle dans une feuille 3, toutes les lignes de la feuille 1 Dont les cellules en colonne O, sont égales à la cellule G.

Exemple : pour G1 = "Papa" en feuille 2, on colle dans la feuille 3, les lignes de la feuille 1 pour lesquelles les cellules de la colonne O sont égales à "Papa".

Puis dans un second temps, on colle dans la colonne A de la feuille 3, le contenu de la cellule H1 de la feuille 2 pour chaque lignes précédemment copiées.

Pourriez-vous m'aider à construire cette macro ?

Merci par avance !

Le 13/08/2018 à 17:41

Bonjour,

Une recherche avec ces mots clés ou en regardant dans les sujets similaires au bas de cette page, tu devrais trouver ton bonheur. En effet le sujet est régulièrement abordé.

Le 13/08/2018 à 18:02

bonjour

salut Pedro22

bémol ; les fils anciens parlent VBA, alors qu'Excel a évolué

l'extraction de données se fait de préférence avec le menu Power Query (sous 2013)

il faut juste le télécharger (add-on gratuit)

joins un fichier exemple, on va voir

Pedro22 (et d'autres) sans doute avec VBA

et moi (et d'autres) sans VBA

Le 13/08/2018 à 20:32

Salut Micka,

Salut l'équipe,

alors, si en plus, on a le feu vert de jmd pour nauséabonder en VBA, on ne va pas se priver, n'est-ce pas?

Un double-clic en 'Feuil2' [E1] ou [G1] déclenche la macro qui affiche le résultat en 'Feuil3'.

Pour les besoins de la cause, j'ai postulé que le terme à inscrire en 'Feuil3' [A...] est le terme à droite de [E1] ou [G1]...

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tData, tExtract()
Dim iRow%, iCol%, sData As String
Cancel = True
'
If Not Intersect(Target, Union(Range("E1"), Range("G1"))) Is Nothing Then
    With Worksheets("Feuil1")
        iRow = .Range("A" & Rows.Count).End(xlUp).Row
        iCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        sData = Target.Offset(0, 1)
        tData = .Range("A1").Resize(iRow, iCol).Value
    End With
    For x = 1 To UBound(tData, 1)
        If tData(x, 15) = Target Then
            iIdx = iIdx + 1
            ReDim Preserve tExtract(iCol, iIdx)
            For y = 1 To iCol
                tExtract(y - 1, iIdx - 1) = IIf(y = 1, sData, tData(x, y))
            Next
        End If
    Next
    With Worksheets("Feuil3")
        .Cells.ClearContents
        .Range("A1").Resize(iIdx, iCol) = WorksheetFunction.Transpose(tExtract)
        .Activate
    End With
End If
'
End Sub

A+

6mickamove.xlsm (19.51 Ko)
Le 14/08/2018 à 10:41

Bonjour curulis57 ,

Merci beaucoup pour ce code, il fonctionne pour ton fichier mais quand j'essaye de l'appliquer au mien, j'ai une erreur d’exécution 5.

Voir en PJ mon fichier.

Est-il possible d'adapter le code pour qu'il fonctionne avec plusieurs lignes en feuille 2 ?

Merci par avance !!

5classeur1.xlsm (21.47 Ko)
Le 14/08/2018 à 10:59

re à tous

Curulis57,

comme je l'ai dit maintes fois, je respecte au plus haut point tous ceux qui interviennent sur le forum, les VBAistes tout autant que les autres

mais je rappelle que VBA est inutile, depuis bientôt 10 ans. Tu n'y es pour rien, ni moi non plus.

le conseil est donc aux VBAistes, qui sont des experts en programmation, d'apprendre aussi Power Query (et Power BI Desktop gratuit). Un jeu pour eux.

et aux non VBAistes et aux "débutants", de commencer par Power Query (et Power BI Desktop gratuit)

VBA viendra plus tard, ou même jamais.

amitiés excelliennes

Le 14/08/2018 à 12:48

Salut Micka,

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tData, tExtract()
Dim iRow%, iCol%, sData As String
Cancel = True
'
If Not Intersect(Target, Range("G2:G" & Range("G" & Rows.Count).End(xlUp).Row)) Is Nothing Then
    With Worksheets("Feuil1")
        iRow = .Range("A" & Rows.Count).End(xlUp).Row
        iCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        sData = Target.Offset(0, 1)
        tData = .Range("A1").Resize(iRow, iCol).Value
    End With
    For x = 1 To UBound(tData, 1)
        If tData(x, 15) = Target Then
            iIdx = iIdx + 1
            ReDim Preserve tExtract(iCol, iIdx)
            For y = 1 To iCol
                tExtract(y - 1, iIdx - 1) = IIf(y = 1, sData, tData(x, y))
            Next
        End If
    Next
    If iIdx > 0 Then
        With Worksheets("Feuil3")
            .Cells.ClearContents
            .Range("A1").Resize(iIdx, iCol) = WorksheetFunction.Transpose(tExtract)
            .Activate
        End With
    Else
        MsgBox "Pas de correspondance!", vbInformation + vbOKOnly, "Info"
    End If
End If
'
End Sub

A+

Le 14/08/2018 à 17:00

Merci curulis57 !!

C'est presque parfait :

Le seul hic c'est que le résultat en feuille 3 ne prend en compte que la première cellule, il faut double cliquer sur chaque cellule pour voir le résultat.

N'y a t'il pas un moyen d'obtenir le résultat de toutes les cellules sur la feuille 3 ?

Le 14/08/2018 à 18:31

Salut Micka,

on peut tout faire (plus vite) quand on s'explique clairement!

Double-clic en [G1] pour démarrer la macro.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tData1, tData2, tExtract()
Dim iRow%, iCol%, sData As String
Cancel = True
'
If Not Intersect(Target, Range("G1")) Is Nothing Then
    With Worksheets("Feuil1")
        iRow = .Range("A" & Rows.Count).End(xlUp).Row
        iCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        tData1 = .Range("A1").Resize(iRow, iCol).Value
    End With
    tData2 = Range("G2:H" & Range("G" & Rows.Count).End(xlUp).Row).Value
    For w = 1 To UBound(tData2, 1)
        For x = 1 To UBound(tData1, 1)
            If tData1(x, 15) = tData2(w, 1) Then
                iIdx = iIdx + 1
                ReDim Preserve tExtract(iCol, iIdx)
                For y = 1 To iCol
                    tExtract(y - 1, iIdx - 1) = IIf(y = 1, tData2(w, 2), tData1(x, y))
                Next
            End If
        Next
    Next
    If iIdx > 0 Then
        With Worksheets("Feuil3")
            .Cells.ClearContents
            .Range("A1").Resize(iIdx, iCol) = WorksheetFunction.Transpose(tExtract)
            .Activate
        End With
    Else
        MsgBox "Pas de correspondance!", vbInformation + vbOKOnly, "Info"
    End If
End If
'
End Sub

A+

Le 14/08/2018 à 18:36

re à tous

c'est un jeu de piste pas clair ton fichier !

comment a été réifié le système des données ?

en gros, quels sont les objets ou entités réels que tu gères ?

machines,

personnes,

articles vendus fabriqués dépannés

mesures ou tests

fiches de dépannage

ventes

achats

ensuite on verra comment les mettre en relation dans Excel

sans cette analyse, tu vas avoir des difficultés sans fin. Que ce soit avec VBA ou sans. Et même si tu passes un jour à autre chose qu'Excel.

je te plains d'avoir SAP, mais c'est une autre histoire.

cependant, as-tu SAP HANA ?

car https://docs.microsoft.com/fr-fr/power-bi/desktop-sap-hana

Rechercher des sujets similaires à "vba copier ligne feuille condition"