XL 2021 Copier une plage de données d'après un critère en VBA

[fenec]

Bonjour le forum,
Besoin de votre aide pour pouvoir copier une plage de données dans une autre feuille si une celle contient l'argument "Actif".
je vous joint un fichier avec le code que j'ai trouvé mais qui ne tient compte de l'argument et qui me recopier les lignes déjà copier.

En espérant avoir été clair,
D'avance merci

 

[job75]

Il suffit de cliquer sur la coche (dans un cercle vert) à droite du post que vous voulez marquer comme solution.

 

[job75]

Bonjour fenec, le forum,

Au post #14 j'ai mis un seul message, au bon endroit.

A+

 

[fenec]

Bonjour le forum,

Je reviens vers vous suite à une demande de ma hiérarchie qui souhaite le document sur une seule page plutôt que sur 3 actuellement.
Par conséquent besoin de votre aide afin de savoir s'il est possible de faire fonctionner la macro de sylvanu ou celle de job 75?

J'ai bien essayer en faisant la recherche de la cellule qui défini le poste mais n'y suis pas parvenu d'où mon retour vers vous.

En espérant la chose réalisable,

Cordialement,
Fenec.

 

[job75]

Bonsoir fenec, le forum,

Voyez le fichier joint et le code de la feuille (clic droit sur l'onglet et Visualiser le code) :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim colSource%, colDest%, ligvide&, lig&, col%
colSource = Target.Column
If Target.Row <> 60 Or colSource <> 2 And colSource <> 31 And colSource <> 60 Then Exit Sub
Cancel = True
colDest = Switch(colSource = 2, 31, colSource = 31, 60, colSource = 60, 2)
Regroupe colDest, ligvide 'regroupe la zone de destination
Application.ScreenUpdating = False
For lig = 64 To 70 Step 2
    If Cells(lig, colSource + 4) = "Actif" Then
        If ligvide > 70 Then MsgBox "Il n'y a plus de ligne vide en zone de destination !", 48: Exit For
        For col = 0 To 20
            Cells(ligvide, colDest + col) = Cells(lig, colSource + col).Value2 'copie la valeur
        Next col
        Cells(lig, colSource).Resize(, 21) = "" 'efface la ligne source
        ligvide = ligvide + 2
    End If
Next lig
Regroupe colSource 'regroupe la zone source
Application.Goto Cells(60, colDest), True 'cadrage sur la destination
ActiveWindow.SmallScroll ToRight:=-1
ActiveWindow.SmallScroll Down:=-10
End Sub

Sub Regroupe(colDest%, Optional ligvide&)
Dim lig&, col%
ligvide = 64
For lig = 64 To 70 Step 2
    If Application.CountA(Cells(lig, colDest).Resize(, 21)) Then 'si la ligne n'est pas vide
        For col = 0 To 20
            Cells(ligvide, colDest + col) = Cells(lig, colDest + col).Value2 'copie la valeur
        Next col
        If lig > ligvide Then Cells(lig, colDest).Resize(, 21) = "" 'efface la ligne
        ligvide = ligvide + 2
    End If
Next lig
End Sub

La 1ère macro se déclenche lorsqu'on double-clique sur Matin Soir ou Nuit.

Bonne nuit.

 

[fenec]

Bonjour le forum, job75?

Je viens de regarder ton fichier et je trouve ta solution très bien pour moi, mais pour mes collaborateurs un peu moi étant tous des novices ou à peu près à l'informatique ce qui me pousse à abuser de ta gentillesse en te demandant s'il serait possible d'avoir

un sub

plutôt qu'un

BeforeDoubleClick

comme cela je pourrais l'insérer dans une autre macro d'enregistrement par exemple et ainsi éviter les oublies de transfert de données.
Je sais que j'abuse et je comprendrais tout à fait si vous ne répondiez plus.

Cordialement,
Fenec.

 

[job75]

Bonjour fenec, le forum,

Il y avait une coquille dans le code précédent, je viens de le corriger.

Je vais vous faire une macro commandée par des boutons.

A+

 

[job75]

Cette macro est maintenant affectée à chacun des 3 boutons "Transfert" :

Sub Transfert()
Dim colSource%, colDest%, ligvide&, lig&, col%
colSource = ActiveSheet.Shapes(Application.Caller).TopLeftCell.MergeArea.Column
colDest = Switch(colSource = 2, 31, colSource = 31, 60, colSource = 60, 2)
Regroupe colDest, ligvide 'regroupe la zone de destination
Application.ScreenUpdating = False
For lig = 64 To 70 Step 2
    If Cells(lig, colSource + 4) = "Actif" Then
        If ligvide > 70 Then MsgBox "Il n'y a plus de ligne vide en zone de destination !", 48: Exit For
        For col = 0 To 20
            Cells(ligvide, colDest + col) = Cells(lig, colSource + col).Value2 'copie la valeur
        Next col
        Cells(lig, colSource).Resize(, 21) = "" 'efface la ligne source
        ligvide = ligvide + 2
    End If
Next lig
Regroupe colSource 'regroupe la zone source
Application.Goto Cells(60, colDest), True 'cadrage sur la destination
ActiveWindow.SmallScroll ToRight:=-1
ActiveWindow.SmallScroll Down:=-10
End Sub

 

[fenec]

Re, job75

Un grand merci à vous pour votre réactivité et votre code qui fonctionne très bien.

Encore merci.
Fenec

 

[fenec]

Bonsoir le forum,

Je reviens vers vous car je rencontre un problème avec le code de Job75, je m'explique:

Ayant voulu personnaliser un peu mon fichier, j'ai fait un bouton maison et de la ma macro ne fonctionne plus ,d'où ma question:

Est-ce mon bouton personnalisé qui pose problème?

Je vous joint un fichier avec ce fameux bouton.

Cordialement,
Fenec.

 

[job75]

Bonjour fenec, le forum,

Chacun de vos 3 boutons est constitué de 2 Shapes, un rectangle et un graphique qui ne doivent pas être groupées, je les ai dissociées.

Dans le fichier joint la macro Transfert est affectée aux rectangles et pour permettre le calcul de :

colSource = ActiveSheet.Shapes(Application.Caller).TopLeftCell.MergeArea.Column

ces 3 rectangles :
- ont été placés au 1er plan
- ont des noms distincts permettant de les étudier séparément par Application.Caller
- ont leur TopLeftCell placées sur les cellules fusionnées des lignes 73:74 pour repérer les colonnes B, AE, BH.

Les graphiques sont toujours en arrière-plan et aucune macro ne leur est affectée.

Vous pouvez maintenant supprimer les boutons "Transfert".

A+

 

[fenec]

Bonjour le forum, job75,

Je suis vraiment désolé, j'étais persuadé avoir répondu à ce post.

Voila erreur rectifie et comme toujours vos êtes top, un grand merci à vous.

J'éviterais à présent de me mettre dans la mouise si je ne métrise pas.

Cordialement,

Fenec.

 

[oguruma]

Bonjour/Bonsoir le fil
un exemple ICI avec le caller : plusieurs boutons appelant la même fonction MAIN dans le code. L'aiguillage se fait par le nom affecté au SHAPE si cela peut t'aider pour d'autres développements.

Extrait de la fonction MAIN appelée dans les Shapes

 Dim vAppel As Variant
...
...

sType = TypeName(Application.Caller)

    Select Case sType
        Case "Range"
            vAppel = Application.Caller.Address
        Case "String"
            vAppel = Application.Caller
        Case "Error"
            vAppel = "Error"
        Case Else
            vAppel = "unknown"
    End Select
    
    If sType <> "String" Then
        MsgBox oMsg.GetMessage("M_MSG001"), vbExclamation, APPLI
        Error.Raise ERROR_PQW, ERROR_PQW_SOURCE, ERROR_PQW_MSG
        Exit Sub
    End If
    
    '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
    ' Bouton de la source
    '=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=
    Select Case vAppel
        Case "FOLDER_SOURCE"
            Call GET_FILE_NAME_XL(SOURCE)
            
        Case "FOLDER_CIBLE"
            Call GET_FILE_NAME_XL(CIBLE)
            
        Case "BTN_INVENTORIER_SOURCE", "SH_INVENTORIER_SOURCE"
            Call INVENTORIER(SOURCE, DIALOG)
            
        Case "BTN_INVENTORIER_CIBLE", "SH_INVENTORIER_CIBLE"
            Call INVENTORIER(CIBLE, DIALOG)
        
        Case "BTN_COPY_OFF"
            Call SET_OPTION_COLUMN("COPIE", SOURCE, SET_NON, DIALOG)
            
        Case "BTN_COPY_ON"
            Call SET_OPTION_COLUMN("COPIE", SOURCE, SET_OUI, DIALOG)
            
        Case "BTN_DATA_OFF"
            Call SET_OPTION_COLUMN("DATA", SOURCE, SET_NON, DIALOG)
            
        Case "BTN_DATA_ON"
            Call SET_OPTION_COLUMN("DATA", SOURCE, SET_OUI, DIALOG)
            
        Case "BTN_FORCE_OFF"
            Call SET_OPTION_COLUMN("FORCE", SOURCE, SET_NON, DIALOG)
            
        Case "BTN_FORCE_ON"
            Call SET_OPTION_COLUMN("FORCE", SOURCE, SET_OUI, DIALOG)
            
        Case "BTN_IMPORTER_CIBLE", "SH_IMPORTER_CIBLE"
            Call IMPORTER_QUERIES(DIALOG)
            
        Case "SH_IMPORTER_RQ_TXT"
            IMPORTER_QUERY_TXT (DIALOG)
            
        Case "SH_EXPORT_TEXTE"
            Call VOIR_REQUETE("TXT", DIALOG)
            
        Case "BTN_VOIR"
            Call VOIR_REQUETE("FRM", DIALOG)
        
        Case "SH_POUBELLE"
            Call SUPPRIMER_QUERY(DIALOG)
            
        Case "SH_BANNIERE"
            MsgBox "Version " & VERSION, vbInformation, APPLI
            
        Case "SH_ACTUALISER"
            Call INVENTORIER(CIBLE, NO_DIALOG)
            
        Case Else
            MsgBox oMsg.GetMessage("M_MSG001"), vbExclamation, APPLI
    End Select