Fusion de cellule et copie de valeur

Y compris Power BI, Power Query et toute autre question en lien avec Excel
a
aceathena
Nouveau venu
Nouveau venu
Messages : 8
Inscrit le : 15 janvier 2013
Version d'Excel : 2003 FR

Message par aceathena » 24 décembre 2019, 11:29

Ca m'a l'air pas mal mais compliquer à adapter avec mes capacités sous Excel. bon c'est une bonne manière pour apprendre. Je vais me pencher dessus.
En tout cas merci beaucoup.
Avatar du membre
xorsankukai
Membre impliqué
Membre impliqué
Messages : 1'954
Appréciations reçues : 206
Inscrit le : 7 octobre 2014
Version d'Excel : 2010 FR

Message par xorsankukai » 24 décembre 2019, 11:32

Re,

@IronBoule:
Dans cette optique, ta seconde solution me paraît être la plus judicieuse quant à la demande initiale.
Non, c'était juste un "bricolage" pour te montrer le résultat attendu d'après ce que j'avais compris, :wink:

Avec le fichier fourni, je comprends mieux la demande, :lole:
Compliqué....mais Steelson est sur l'affaire, :)

Cordialement,
xorsankukai

La connaissance, c’est partager le savoir qui nous fait grandir.
a
aceathena
Nouveau venu
Nouveau venu
Messages : 8
Inscrit le : 15 janvier 2013
Version d'Excel : 2003 FR

Message par aceathena » 24 décembre 2019, 11:37

Ca m'a l'air pas mal mais compliquer à adapter avec mes capacités sous Excel. bon c'est une bonne manière pour apprendre. Je vais me pencher dessus.
En tout cas merci beaucoup.
Avatar du membre
Steelson
Fanatique d'Excel
Fanatique d'Excel
Messages : 13'459
Appréciations reçues : 747
Inscrit le : 13 octobre 2014
Version d'Excel : 2013 FR
Téléchargements : Mes applications

Message par Steelson » 24 décembre 2019, 11:45

On peut continuer sur les 2 solutions avec xorsankukai (°v°)°
Je vais essayer de faire une adaptation assez simple du fichier que je t'ai proposé.

O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸ O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸
PI = 3.14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280

( ͡• ͜ʖ ͡• )
Avatar du membre
Steelson
Fanatique d'Excel
Fanatique d'Excel
Messages : 13'459
Appréciations reçues : 747
Inscrit le : 13 octobre 2014
Version d'Excel : 2013 FR
Téléchargements : Mes applications

Message par Steelson » 24 décembre 2019, 15:55

J'ai commencé, mais n'attends pas une réponse avant jeudi ...
Un truc qui me chiffonne ... les 20mn de pause qui ne collent pas avec le découpage en 1/4 d'heures ! On peut passer à un découpage en 20mn ?

O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸ O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸
PI = 3.14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280

( ͡• ͜ʖ ͡• )
Avatar du membre
Steelson
Fanatique d'Excel
Fanatique d'Excel
Messages : 13'459
Appréciations reçues : 747
Inscrit le : 13 octobre 2014
Version d'Excel : 2013 FR
Téléchargements : Mes applications

Message par Steelson » 26 décembre 2019, 00:43

Bonjour,

une première version de ma proposition adaptée et paramétrée (l'userform est créé d'après le tableau des codes dans l'onglet synthèse)
Option Explicit
Public plage As Range

Sub CreerUSF()
Dim NewB As MSForms.CommandButton
Dim myUSF As Object
Dim i As Integer, n As Integer
Dim param As Object
Set param = Sheets("synthese").ListObjects(1)

    supprimerTousUSF

    Set myUSF = ThisWorkbook.VBProject.VBComponents.Add(3)
    With myUSF
        .Properties("Caption") = "Choisir ..."
        .Properties("Width") = 170
        .Properties("Height") = (param.ListRows.Count + 2) * 25 - 10
        '.Properties("ShowModal") = True
    End With
    With myUSF.CodeModule
        i = .CountOfLines
        If i = 2 Then
            .InsertLines i, "": i = i + 1
        Else
            i = 1
        End If
    End With
    
    For n = 1 To param.ListRows.Count
        Set NewB = myUSF.Designer.Controls.Add("Forms.CommandButton.1")
        With NewB
            .Height = 20
            .Width = 125
            .Left = 20
            .Top = 25 * n - 15
            .BackColor = param.DataBodyRange.Cells(n, 1).Interior.Color
            .Caption = param.DataBodyRange.Cells(n, 1) & " : " & param.DataBodyRange.Cells(n, 2)
        End With
        myUSF.CodeModule.InsertLines i, "Private Sub CommandButton" & n & "_Click()": i = i + 1
        myUSF.CodeModule.InsertLines i, "    If ActiveSheet.Name <> ""planning"" Or plage Is Nothing Then Exit Sub": i = i + 1
        myUSF.CodeModule.InsertLines i, "    For Each cel In plage": i = i + 1
        myUSF.CodeModule.InsertLines i, "        cel.Value = Split(CommandButton" & n & ".Caption, "" : "")(0)": i = i + 1
        myUSF.CodeModule.InsertLines i, "        cel.Interior.Color = CommandButton" & n & ".BackColor": i = i + 1
        myUSF.CodeModule.InsertLines i, "    Next": i = i + 1
        myUSF.CodeModule.InsertLines i, "    'Me.Hide": i = i + 1
        myUSF.CodeModule.InsertLines i, "End Sub": i = i + 1
    Next
    
End Sub

Sub supprimerTousUSF()
'nécéssite d'activer la référence Microsoft Visual Basic For Applications Extensibility 5.3
Dim VBCmp As VBComponent
    For Each VBCmp In ThisWorkbook.VBProject.VBComponents
        If VBCmp.Type = 3 Then ThisWorkbook.VBProject.VBComponents.Remove VBComponent:=VBCmp
    Next VBCmp
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Set plage = Intersect(Target, Range(Cells(3, 3), Cells(Cells(Rows.Count, 2).End(xlUp).Row, Cells(2, Columns.Count).End(xlToLeft).Column)))
    If plage Is Nothing Then Exit Sub
    plage.Select
    On Error GoTo autre
    UserForm1.Show 0
    Exit Sub
autre:
    UserForm2.Show 0
End Sub
planning aceathena v1.xlsm
(38.4 Kio) Téléchargé 19 fois

O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸ O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸
PI = 3.14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280

( ͡• ͜ʖ ͡• )
Avatar du membre
Steelson
Fanatique d'Excel
Fanatique d'Excel
Messages : 13'459
Appréciations reçues : 747
Inscrit le : 13 octobre 2014
Version d'Excel : 2013 FR
Téléchargements : Mes applications

Message par Steelson » 26 décembre 2019, 07:59

une correction pour plus de réactivité
Option Explicit
Public plage As Range

Sub CreerUSF()
Dim NewB As MSForms.CommandButton
Dim myUSF As Object
Dim i As Integer, n As Integer
Dim param As Object
Set param = Sheets("synthese").ListObjects(1)

    supprimerTousUSF

    Set myUSF = ThisWorkbook.VBProject.VBComponents.Add(3)
    With myUSF
        .Properties("Caption") = "Choisir ..."
        .Properties("Width") = 170
        .Properties("Height") = (param.ListRows.Count + 2) * 25 - 10
        '.Properties("ShowModal") = True
    End With
    With myUSF.CodeModule
        i = .CountOfLines
        If i = 2 Then
            .InsertLines i, "": i = i + 1
        Else
            i = 1
        End If
    End With
    
    For n = 1 To param.ListRows.Count
        Set NewB = myUSF.Designer.Controls.Add("Forms.CommandButton.1")
        With NewB
            .Height = 20
            .Width = 125
            .Left = 20
            .Top = 25 * n - 15
            .BackColor = param.DataBodyRange.Cells(n, 1).Interior.Color
            .Caption = param.DataBodyRange.Cells(n, 1) & " : " & param.DataBodyRange.Cells(n, 2)
        End With
        myUSF.CodeModule.InsertLines i, "Private Sub CommandButton" & n & "_Click()": i = i + 1
        myUSF.CodeModule.InsertLines i, "    If ActiveSheet.Name <> ""planning"" Or plage Is Nothing Then Exit Sub": i = i + 1
        myUSF.CodeModule.InsertLines i, "    plage.Value = Split(CommandButton" & n & ".Caption, "" : "")(0)": i = i + 1
        myUSF.CodeModule.InsertLines i, "    plage.Interior.Color = CommandButton" & n & ".BackColor": i = i + 1
        myUSF.CodeModule.InsertLines i, "    'Me.Hide": i = i + 1
        myUSF.CodeModule.InsertLines i, "End Sub": i = i + 1
    Next
    
End Sub

Sub supprimerTousUSF()
'nécéssite d'activer la référence Microsoft Visual Basic For Applications Extensibility 5.3
Dim VBCmp As VBComponent
    For Each VBCmp In ThisWorkbook.VBProject.VBComponents
        If VBCmp.Type = 3 Then ThisWorkbook.VBProject.VBComponents.Remove VBComponent:=VBCmp
    Next VBCmp
End Sub
planning aceathena v1bis.xlsm
(44.29 Kio) Téléchargé 19 fois

O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸ O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸
PI = 3.14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280

( ͡• ͜ʖ ͡• )
Avatar du membre
xorsankukai
Membre impliqué
Membre impliqué
Messages : 1'954
Appréciations reçues : 206
Inscrit le : 7 octobre 2014
Version d'Excel : 2010 FR

Message par xorsankukai » 26 décembre 2019, 11:24

Bonjour le fil,
Bonjour Steelson,
En fait, j'ai test1 dans la cellule A1, je fusionne sur A1 à A5 et je souhaiterais que les cellule A2, A3, A4 et A5 prenne la valeur Test1. Mais que ça n'apparaissent pas.
J'en étais resté sur une simple MFC pour donner l'illusion de cellules fusionnées, ...le rendu semble correct hormis le fait que je n'affiche aucun texte dans les cellules(mais bon, il y a la légende des couleur en bas, :lole: ).
Test.xlsm
(30.53 Kio) Téléchargé 21 fois
Cordialement,
xorsankukai

La connaissance, c’est partager le savoir qui nous fait grandir.
Avatar du membre
Steelson
Fanatique d'Excel
Fanatique d'Excel
Messages : 13'459
Appréciations reçues : 747
Inscrit le : 13 octobre 2014
Version d'Excel : 2013 FR
Téléchargements : Mes applications

Message par Steelson » 27 décembre 2019, 11:12

Evolution ...

ATTENTION = la proposition nécessite de cocher la case "Accès approuvé au modèle d'objet du projet VBA" dans les options "sécurité des Macro". Le planning n'est pas réellement exportable.

Donc voici une version plus basique ...
planning aceathena.xlsm
(47.17 Kio) Téléchargé 20 fois
avec pour le gestionnaire-administrateur un outil de création des userform qui lui nécessite l'accès approuvé ...
creation userform.xlsm
(32.75 Kio) Téléchargé 12 fois

O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸ O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸
PI = 3.14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280

( ͡• ͜ʖ ͡• )
Avatar du membre
Steelson
Fanatique d'Excel
Fanatique d'Excel
Messages : 13'459
Appréciations reçues : 747
Inscrit le : 13 octobre 2014
Version d'Excel : 2013 FR
Téléchargements : Mes applications

Message par Steelson » 30 décembre 2019, 08:59

Steelson a écrit :
27 décembre 2019, 11:12
ATTENTION = la proposition nécessite de cocher la case "Accès approuvé au modèle d'objet du projet VBA" dans les options "sécurité des Macro". Le planning n'est pas réellement exportable.
Cela ma tracassait, du coup je pense avoir réussi une version bien plus intéressante : macro simple et unique sans passer par un module de classe
Sub Executer()
    If Not plage Is Nothing Then
        With ActiveSheet.Shapes(Application.Caller)
            plage = Split(.TextFrame.Characters.Text, " : ")(0)
            plage.Interior.Color = .Fill.ForeColor.RGB
            plage.Font.Color = .TextFrame.Characters.Font.Color
        End With
    Else
        MsgBox "Sélectionner une plage de cellules !"
    End If
End Sub 
pas de userform, pas d'écrire de macro par macro ...et normalement utilisable sur mac (je n'ai pas testé).

Le code complet est le suivant ...
Option Explicit
Public plage As Range
Const feuille = "planning" ' feuille principale dans laquelle sera affichée le menu
Const parametre = "synthese" ' feuille dans laquelle on trouvera les différents codes
Dim posx As Integer, posy As Integer

Sub AfficherChoix()
    CreerMenu 1
End Sub

Sub CreerMenu(y As Integer)
Dim i As Integer, j As Integer, k As Integer, n As Integer, Sh As Object
Dim param As Object
Set param = Sheets("synthese").ListObjects(1)
Dim groupe As Object
Set groupe = Sheets("synthese").ListObjects(2)

    position True
    
    For Each Sh In Worksheets(feuille).Shapes
        Sh.Delete
    Next
    
    With Worksheets(feuille).Shapes.AddShape(msoShapeRectangle, _
        posx, posy, 195, (WorksheetFunction.CountIf(param.ListColumns(3).DataBodyRange, y) + groupe.ListRows.Count) * 25 + 50)
        .Name = "Menu"
        .Fill.ForeColor.RGB = groupe.DataBodyRange.Cells(y, 2).Interior.Color
    End With
        
    n = 1
        
    For j = 1 To groupe.ListRows.Count
            
        With Worksheets(feuille).Shapes.AddShape(msoShapeRoundedRectangle, posx + 5, posy + 25 * n - 10, 165, 20)
            .Name = "Menu" & n
            .TextFrame.Characters.Text = groupe.DataBodyRange.Cells(j, 1) & IIf(j = y, " : ", "")
            .TextFrame.Characters.Font.Color = groupe.DataBodyRange.Cells(j, 2).Font.Color
            .Fill.ForeColor.RGB = groupe.DataBodyRange.Cells(j, 2).Interior.Color
            .OnAction = "'Changer(" & j & ")'"
        End With
        n = n + 1
        
        If j = y Then
            For k = 1 To param.ListRows.Count
                If param.DataBodyRange.Cells(k, 3) = y Then
                
                    With Worksheets(feuille).Shapes.AddShape(msoShapeRoundedRectangle, posx + 20, posy + 25 * n - 10, 165, 20)
                        .Name = "Menu" & n
                        .TextFrame.Characters.Text = param.DataBodyRange.Cells(k, 1) & " : " & param.DataBodyRange.Cells(k, 2)
                        .TextFrame.Characters.Font.Color = param.DataBodyRange.Cells(k, 1).Font.Color
                        .Fill.ForeColor.RGB = param.DataBodyRange.Cells(k, 1).Interior.Color
                        .OnAction = "'Executer True'"
                    End With
                    n = n + 1
                
                End If
            Next
    
            With Worksheets(feuille).Shapes.AddShape(msoShapeRoundedRectangle, posx + 20, posy + 25 * n - 10, 165, 20)
                .Name = "Menu" & n
                .TextFrame.Characters.Text = "Effacer"
                .TextFrame.Characters.Font.Color = RGB(0, 0, 0)
                .Fill.ForeColor.RGB = RGB(255, 255, 255)
                .OnAction = "'Effacer True'"
            End With
            n = n + 1

        End If
    Next
    
    regrouper "Menu"
    
End Sub

Sub position(OK As Boolean)
On Error GoTo fin
    With Sheets(feuille).Shapes("Menu")
        posx = .Left
        posy = .Top
    End With
    Exit Sub
fin:
    posx = 400
    posy = 100
End Sub

Sub regrouper(texte As String)
    Dim Sh As Shape
    Dim Tableau() As String
    Dim i As Integer
 
    For Each Sh In ActiveSheet.Shapes
        If Left(Sh.Name, Len(texte)) = texte Then
            i = i + 1
            ReDim Preserve Tableau(1 To i)
            Tableau(i) = Sh.Name
        End If
    Next
 
    If i = 0 Then Exit Sub
 
    Set Sh = ActiveSheet.Shapes.Range(Tableau).Group
    Sh.Name = "LeMenu"
    Sh.Shadow.Type = msoShadow21
    
End Sub

Sub Executer(OK As Boolean)
    If Not plage Is Nothing Then
        With ActiveSheet.Shapes(Application.Caller)
            plage = Split(.TextFrame.Characters.Text, " : ")(0)
            plage.Interior.Color = .Fill.ForeColor.RGB
            plage.Font.Color = .TextFrame.Characters.Font.Color
        End With
    Else
        MsgBox "Sélectionner une plage de cellules !"
    End If
End Sub

Sub Effacer(OK As Boolean)
    If Not plage Is Nothing Then
        plage.ClearContents
        plage.Interior.ColorIndex = xlNone
    Else
        MsgBox "Sélectionner une plage de cellules !"
    End If
End Sub

Sub Changer(k As Integer)
    CreerMenu k
    ThisWorkbook.Names("MenuEnCours").RefersTo = k
End Sub

planning creation du menu (shapes).xlsm
(47.04 Kio) Téléchargé 16 fois

O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸ O.o°• ♪♪♫ °º¤ø,¸¸,ø¤º°`°º¤ø,¸
PI = 3.14159 26535 89793 23846 26433 83279 50288 41971 69399 37510 58209 74944 59230 78164 06286 20899 86280

( ͡• ͜ʖ ͡• )
Répondre Sujet précédentSujet suivant
  • Sujets similaires
    Réponses
    Vues
    Dernier message