Discussion :

[Neversoft]

Bonjour

J'aurais besoin d'un peu d'aide pour une macro, j'imagine rien de bien compliqué, mais ca fait des heures que j'essaye d'adapter des bouts de code et rien ne marche ...

J'ai une classeur Excel, ou je travaille sur la feuille 8.
Et j'aimerais que lorsque je passe une cellule de la colonne B en vert, la ligne complète soit transférée vers la première ligne libre de la feuille 10

Est il possible que la macro se lance automatiquement lorsqu'on modifie la couleur d'une cellule en colonne B ?

En vous remerciant par avance

Cordialement,

[Jean-Philippe André]

Salut,

un bout de code trouve sur un forum anglophone

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
Option Explicit
 
Private bXitLoop As Boolean
Private bLoopRunning As Boolean
 
Public Sub WatchCellColor()
 
    Const MSG1 As String = "You Changed the Color of Range : "
    Const MSG2 As String = "Do you want to restore the previous color ?"
    Dim vCellCurColor() As Variant
    Dim vCellPrevColor() As Variant
    Dim sCellAddrss() As String
    Dim sVisbRngAddr As String
    Dim bAllCellsCounted As Boolean
    Dim oCell As Range
    Static i As Long
 
    bAllCellsCounted = False
    If bLoopRunning Then Exit Sub
    bXitLoop = False
    Do
        bLoopRunning = True
        i = -1
VisibleRngChanged:
        If sVisbRngAddr <> ActiveWindow.VisibleRange.Address _
        And sVisbRngAddr <> "" Then
            Erase sCellAddrss
            Erase vCellCurColor
            Erase vCellPrevColor
            sVisbRngAddr = ""
            bAllCellsCounted = False
            GoTo VisibleRngChanged
        End If
        On Error Resume Next
            For Each oCell In ActiveWindow.VisibleRange.Cells
                ReDim Preserve sCellAddrss(i + 1)
                ReDim Preserve vCellCurColor(i + 1)
                sCellAddrss(i + 1) = oCell.Address
                vCellCurColor(i + 1) = oCell.Interior.Color
                If vCellPrevColor(i + 1) <> vCellCurColor(i + 1) Then
                    If bAllCellsCounted = True Then
                        If MsgBox(MSG1 & oCell.Address & vbNewLine & MSG2, vbQuestion + vbYesNo) _
                        = vbYes Then
                            oCell.Interior.Color = vCellPrevColor(i + 1)
                            vCellCurColor(i + 1) = vCellPrevColor(i + 1)
                        End If
                    End If
                End If
                i = i + 1
                If i + 1 >= ActiveWindow.VisibleRange.Cells.Count Then
                    bAllCellsCounted = True
                    ReDim Preserve vCellPrevColor(UBound(vCellCurColor))
                    vCellPrevColor = vCellCurColor
                    End If
                vCellPrevColor(i + 1) = vCellCurColor(i + 1)
            Next
        On Error GoTo 0
        sVisbRngAddr = ActiveWindow.VisibleRange.Address
        DoEvents
    Loop Until bXitLoop
    bLoopRunning = False
 
End Sub
 
Public Sub StopWatching()
 
    bXitLoop = True
 
End Sub

Lance la premiere macro et change ensuite la couleur d'une cellule