Microsoft 365 Première cellule vide ou égal zéros dans une plage définie

[juju91]

Re bonjour,

Encore un problème que je vous soumets
J'ai ''créé'' le petit code ci-dessous qui permet que copier la cellule active et celle adjacente dans la première cellule vide d'une autre colonne.

J'ai plusieurs problème..
Je souhaiterais coller (la valeur) des deux cellules dans la première cellule qui et vide OU la première cellule qui est égal à zéro.
et si possible avoir un message qui s'affiche si toutes les cellules de la plage définie sont déjà remplies ( hors vide ou résultat formule égal à zéro)

Private Sub COPIE_BAR_Click()
Application.ScreenUpdating = False
Cells(ActiveCell.Row, "B").Select
ActiveCell.Offset(, 0).Resize(, 2).Copy
Cells(ActiveCell.Row, "j").Select
Range("J74:J18").Select
Selection.End(xlDown).Select
Selection.Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.ScreenUpdating = True
End Sub


je joins u fichier pour que ma demande soit plus simple à comprendre.....


Cdt

 

[sousou]

Bonjour.
pas tout compris!
peut-tu préciser en donnant un exemple du résultat à obtenir
je click (ici) je copie tels cellules à cet emplacement.
c'est quoi la plage définit?
quid des ligne masquée?

 

[fanch55]

Bonjour, pareil que @sousou
Le code ne colle pas à ce que tu décris, tu veux copier où ?
je présume qu'en fait Range("J74:J18").Select serait plutôt Range("J74:J78").Select ?
Associer autant d'activex ne va pas forcément t'aider

 

[gbinforme]

Bonjour à tous
Avec ce que j'ai compris ce code devrait fonctionner :

Private Sub COPIE_BAR_Click()
Dim cel As Range
    Cells(ActiveCell.Row, "B").Resize(1, 2).Copy
    For Each cel In Range("J74:J78")
        If IsEmpty(cel) Or cel.Value = 0 Then
            cel.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Exit For
        End If
    Next cel
End Sub

 

[fanch55]

Bonjour à tous
Avec ce que j'ai compris ce code devrait fonctionner :

Private Sub COPIE_BAR_Click()
Dim cel As Range
    Cells(ActiveCell.Row, "B").Resize(1, 2).Copy
    For Each cel In Range("J74:J78")
        If IsEmpty(cel) Or cel.Value = 0 Then
            cel.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        End If
    Next cel
End Sub

Salut @gbinforme,
attention: Cells(ActiveCell.Row, "B") ne présume pas que ce soit la cellule associée à l'activex ...

 

[fanch55]

Ci-dessous un code qui devrait répondre à votre demande si je l'ai bien interprétée :

Option Explicit

Private Sub COPIE_BAR_Click()
    Copy_Zone "Copie_Bar", [J74:J78]
End Sub

Private Sub CommandButton2_Click()
    Copy_Zone "CommandButton2", [J74:J78]
End Sub

Private Sub CommandButton3_Click()
    Copy_Zone "CommandButton3", [J74:J78]
End Sub

Sub Copy_Zone(Btn_Name As String, Zone As Range)
    Dim Target As Range
    Me.Shapes(Btn_Name).TopLeftCell.Resize(, 2).Copy
    
    Set Target = Zone.Find("", Zone.Cells(Zone.Rows.Count), LookIn:=xlValues, searchdirection:=xlNext)
    If Target Is Nothing Then Set Target = Zone.Find(0, Zone.Cells(Zone.Rows.Count), LookIn:=xlValues, searchdirection:=xlNext)
    If Not Target Is Nothing Then
        Target.Resize(, 2).PasteSpecial Paste:=xlPasteValues
    Else
        MsgBox "Pas de celulles disponibles dans la zone " & Zone.Address, vbCritical
    End If

End Sub

Attention, il n'évite pas les doublons

 

[gbinforme]

Salut @gbinforme,
attention: Cells(ActiveCell.Row, "B") ne présume pas que ce soit la cellule associée à l'activex ...

re
c'est bien celle qui est active que l'on copie comme dans la demande indépendamment du bouton.

 

[fanch55]

re
c'est bien celle qui est active que l'on copie comme dans la demande indépendamment du bouton.

Que ce soit n'importe quelle cellule sélectionnée n'a pas de sens ,
mais c'est effectivement la demande initiale ....

 

[fanch55]

Une solution sans passer par des activex :

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error Resume Next: [zoneCopy].Delete: On Error GoTo 0
    
    Select Case True
    Case Target.Count > 1
    Case Target = ""
    Case Target.Column = Columns("B").Column
        With Me.Shapes.AddShape(msoShapeRightArrow, Target.Left + 5, Target.Top, 20, Target.Height)
            .Name = "zoneCopy"
            .OLEFormat.Object.Interior.Color = RGB(255, 255, 204)
            .OnAction = Me.CodeName & ".Copy_Zone"
        End With
    End Select
End Sub

Public Sub Copy_Zone()
    Dim Target As Range, Source As Range, Zone As Range
    Dim StartCell As Range, EndCell As Range
    
' Pour déterminer la plage d'application ( Zone ),
' on se base sur les bordures de séparation des lignes
' la ligne de début a la bordure supérieure <> Pointillé (xlHairline)
' la ligne de fin a la bordure inférieure <> Pointillé (xlHairline)

    Set StartCell = Me.Shapes(Application.Caller).TopLeftCell
    Do While (StartCell.Borders(xlEdgeTop).Weight = xlHairline)
        Set StartCell = StartCell.Offset(-1)
    Loop
    
    Set EndCell = Me.Shapes(Application.Caller).TopLeftCell
    Do While (EndCell.Borders(xlEdgeBottom).Weight = xlHairline)
        Set EndCell = EndCell.Offset(1)
    Loop
    
    Set Zone = Range(StartCell, EndCell).Offset(, 8)
    Me.Shapes(Application.Caller).TopLeftCell.Resize(, 2).Copy
    
    Set Target = Zone.Find("", Zone.Cells(Zone.Rows.Count), xlValues, SearchDirection:=xlNext)
    If Target Is Nothing Then Set Target = Zone.Find(0, Zone.Cells(Zone.Rows.Count), xlValues, SearchDirection:=xlNext)
    If Not Target Is Nothing Then
        Target.Resize(, 2).PasteSpecial Paste:=xlPasteValues
    Else
        MsgBox "Pas de cellules disponibles dans la zone " & Zone.Address, vbCritical
    End If

End Sub

 

[juju91]

Bonjour et merci à tous.

la solution de FANCH55 poste #6 est parfaite .

il y a juste un petit problème, désolé.
Les cellules copiées sont celles au dessus de la cellule active.
J'aurais souhaité que ce soit la cellule active et adjacente a droite qui soient copiés.
Encore désolé mais je n'arrive pas a modifier le code, pourriez-vous de donner un peu d'aide.

Encore un grand merci, de prendre du temps pour mes demandes.

Cdt

 

[fanch55]

Me.Shapes(Btn_Name).TopLeftCell.Resize(, 2).Copy

Le code fourni copie la cellule se trouvant sous le bouton "Copie_Bar"avec la cellule adjacente à droite de celle-ci .

il y a juste un petit problème, désolé.
Les cellules copiées sont celles au dessus de la cellule active.
J'aurais souhaité que ce soit la cellule active et adjacente a droite qui soient copiés.

Vous voulez dire que lorsque vous cliquez sur le bouton "COPIE_BAR",
vous voulez copier la cellule de la colonne B sur la même ligne que la sélection , cette dernière pouvant être n'importe où ?
Dans ce cas là, à quoi vous servent tous les autres activex de la colonne B ?, le bouton aurait plus sa place à coté de l'activex "Image124"

Voici le code permettant de faire ce que vous décrivez, finalement @gbinforme avait raison , son code aurait pu vous guider .

Option Explicit
Private Sub COPIE_BAR_Click()

    Dim Target As Range
    Dim Zone As Range: Set Zone = [J74:J78]
    Cells(ActiveCell.Row, "B").Resize(, 2).Copy
    
    Set Target = Zone.Find("", Zone.Cells(Zone.Rows.Count), LookIn:=xlValues, searchdirection:=xlNext)
    If Target Is Nothing Then Set Target = Zone.Find(0, Zone.Cells(Zone.Rows.Count), LookIn:=xlValues, searchdirection:=xlNext)
    
    If Not Target Is Nothing _
    Then Target.Resize(, 2).PasteSpecial Paste:=xlPasteValues _
    Else MsgBox "Pas de celulles disponibles dans la zone " & Zone.Address, vbCritical

End Sub