XL 2010 je cherche a extraire les valeurs des celules

  • Initiateur de la discussion Initiateur de la discussion samoooo
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

Bonsoir samoooo, Bruno, JHA,

Voyez le fichier joint et cette macro dans le code de la feuille étudiée :
VB:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim n2%, n1%, coul&
Application.ScreenUpdating = False
With [V6]
    .CurrentRegion.Clear 'RAZ
    Set Target = Intersect(Target, UsedRange)
    If Target Is Nothing Then Exit Sub
    For Each Target In Target
        If CStr(Target) <> "" Then
            coul = Target.DisplayFormat.Interior.Color
            If coul = vbWhite Then
                n2 = n2 + 1
                .Cells(2, n2) = Target
            Else
                n1 = n1 + 1
                With .Cells(1, n1)
                    .Value = Target
                    .Interior.Color = coul
                    .Font.Color = Target.DisplayFormat.Font.Color
                End With
            End If
        End If
    Next
    .CurrentRegion.HorizontalAlignment = xlCenter 'centrage
End With
End Sub
Elle se déclenche quand on sélectionne une plage queiconque

DisplayFormat existe depuis Excel 2007 et récupère tout format y compris ceux des MFC.

Bonne nuit.
 

Pièces jointes

Bonjour samoooo, le forum,
si on peux gader resultats de la partie a etudié a partire de la celulle V6
Avec ce fichier (2) le résultat en V6 est stocké vers le bas par la touche <Entrée> :
VB:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim v, n2%, n1%, coul&
Application.ScreenUpdating = False
With [V6]
    .CurrentRegion.Clear 'RAZ
    Set Target = Intersect(Target, UsedRange)
    If Target Is Nothing Then Exit Sub
    For Each Target In Target
        v = Trim(CStr(Target))
        If v <> "" Then
            coul = Target.DisplayFormat.Interior.Color
            If coul = vbWhite Then
                n2 = n2 + 1
                .Cells(2, n2) = v
            Else
                n1 = n1 + 1
                With .Cells(1, n1)
                    .Value = v
                    .Interior.Color = coul
                    .Font.Color = Target.DisplayFormat.Font.Color
                End With
            End If
        End If
    Next
    .CurrentRegion.HorizontalAlignment = xlCenter 'centrage
    If Application.CountA([V6:V7]) Then Application.OnKey "~", Me.CodeName & ".Entree"
End With
End Sub

Private Sub Entree()
If MsgBox("Stocker le résultat ?", vbYesNo) = vbYes Then _
    Range([V6], Cells(6, Columns.Count)).Resize(3).Insert
Application.OnKey "~" 'RAZ
End Sub
A+
 

Pièces jointes

Ce fichier (3) fait la même chose mais avec le clic droit :
VB:
Dim flag As Boolean 'mémorise la variable

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim v, n2%, n1%, coul&
Application.ScreenUpdating = False
With [V6]
    .CurrentRegion.Clear 'RAZ
    Set Target = Intersect(Target, UsedRange)
    If Target Is Nothing Then Exit Sub
    For Each Target In Target
        v = Trim(CStr(Target))
        If v <> "" Then
            coul = Target.DisplayFormat.Interior.Color
            If coul = vbWhite Then
                n2 = n2 + 1
                .Cells(2, n2) = v
            Else
                n1 = n1 + 1
                With .Cells(1, n1)
                    .Value = v
                    .Interior.Color = coul
                    .Font.Color = Target.DisplayFormat.Font.Color
                End With
            End If
        End If
    Next
    .CurrentRegion.HorizontalAlignment = xlCenter 'centrage
    flag = True
End With
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Not flag Then Exit Sub
Cancel = True
If MsgBox("Stocker le résultat ?", vbYesNo) = vbYes Then _
    Range([V6], Cells(6, Columns.Count)).Resize(3).Insert
flag = False 'RAZ
End Sub
 

Pièces jointes

- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

  • Question Question
Microsoft 365 formule addition
Réponses
4
Affichages
46
Retour