XL 2016 COPIER COLLER CELLULES SELECTIONNEES PAR CASE COCHEE

[gilles42]

Bonjour à toutes et à tous.
J'ai un classeur avec deux feuilles : activite et bdd. J'aimerais qu'en inscrivant "X" (ou juste un clic de souris), dans la case S5, S6, S7 etc.... celà me sélectionne les cellules C5 à F5, C6 à F6, C7 à F7 etc..... de la feuille "activité" pour venir les coller dans mon tableau "bdd". J'aimerais aussi qu'en A:A de "bdd", il y ait un point (.) si la valeur est inférieure ou égale à 0.
Enfin si celà est possible, j'aimerais que mes nouvelles données se classent automatiquement par societe.
Je vous joins une ébauche de mon fichier.
Merci par avance pour votre aide.

 

[job75]

Bonjour gilles42,

Votre fichier était vérolé, je l'ai refait, voyez ci-joint.

Pas besoin de "x", un double-clic sur la ligne à transférer suffit.

Voyez cette macro dans le code de la feuille "Activité" (clic droit sur l'onglet et Visualiser le code) :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Row < 5 Then Exit Sub
Cancel = True
With Sheets("BDD")
    With .Range("A" & .Rows.Count).End(xlUp)(2)
        .Resize(, 4) = Intersect(Target.EntireRow, [C:F]).Value 'copie uniquement les valeurs
        If .Value <= 0 Then .Value = "."
    End With
    .[A1].CurrentRegion.Sort .[B1], xlAscending, Header:=xlYes 'tri sur les sociétés
    .Activate 'facultatif
End With
End Sub

Si vous faites plusieurs fois un double-clic sur la même ligne il y aura bien sûr des doublons... Mais c'est une autre histoire !!!

A+

 

[job75]

Si l'on veut que le résultat soit en majuscules il suffit d'ajouter une boucle, fichier(2) :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Row < 5 Then Exit Sub
Dim c As Range
Cancel = True
With Sheets("BDD")
    With .Range("A" & .Rows.Count).End(xlUp)(2)
        .Resize(, 4) = Intersect(Target.EntireRow, [C:F]).Value 'copie uniquement les valeurs
        If .Value <= 0 Then .Value = "."
        For Each c In .Resize(, 4): c = UCase(c): Next 'majuscules
    End With
    .[A1].CurrentRegion.Sort .[B1], xlAscending, Header:=xlYes 'tri sur les sociétés
    .Activate 'facultatif
End With
End Sub

 

[gilles42]

bonjour JOB75
Vos formules fonctionnent parfaitement bien.
Pouvez vous me dire comment faire pour restreindre ce double-clic au tableau ? Car lorsque je double clic en dehors des limites, la feuille "BDD" s'ouvre.
encore merci pour tout.

 

[job75]

Pouvez vous me dire comment faire pour restreindre ce double-clic au tableau ?

Vous pouvez remplacer If Target.Row < 5 Then Exit Sub par :

If Intersect(Target, [C5:F30,C36:F61]) Is Nothing Then Exit Sub

Mais on peut aussi ne rien limiter : l'utilisateur doit savoir ce qu'il fait non ?

 

[job75]

Finalement ceci n'est pas mal pour limiter :

If Not IsDate(Cells(Target.Row, 2).Text) Or Intersect(Target, [C:F]) Is Nothing Then Exit Sub

Le transfert n'a lieu que s'il y a une heure entrée en colonne B.