Fusion de cellule et copie de valeur

Bonjour à tous,

Je suis chargée par mon responsable de créer une fiche horaire avec le détail de ce que fait le personnel pour faire un reporting plus tard.

Chaque employé devra rentré ses info et les gens ne sont pas très à l'aise avec l'informatique.

Je suis partie sur la fusion de cellule (J'ai bien compris que c'était pas top).

J'ai trouvé une macro pour compter le nombre de cellule fusionnée mais ces fusions me pose problème pour d'autres formules.

Est-il possible de faire une macro afin que quand je fusionne plusieurs cellule, les données se trouvant dans la première cellule se trouve également dans les autres cellules fusionnées? Je ne sais pas si c'est très clair...

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.

quelqu'un peut-il m'aider?

Bonjour aceathena,

A tester :

    Application.DisplayAlerts = False
    Range("A1:A5").Merge
    Application.DisplayAlerts = True

Cela permet de fusionner les cellules en gardant la valeur de la 1ère cellule.

Cordialement,

Bonjour,

Est-il possible de faire une macro afin que quand je fusionne plusieurs cellule, les données se trouvant dans la première cellule se trouve également dans les autres cellules fusionnées?

Non, la fusion de cellules permet de conserver uniquement la donnée de la cellule en haut à gauche. Les autres sont perdues.

Bonjour aceathena, IronBoule, le forum,

@Ironboule :

Cela permet de fusionner les cellules en gardant la valeur de la 1ère cellule.

Oui, mais qu'en est-il de A2,A3,A4 et A5 ?

Étant parti sur le meme code, j'avais fait le test, mais regarde le fichier joint :

18fusion.xlsm (19.32 Ko)

Peut-être que si aceathena joignait un fichier, on comprendrait mieux le but de la demande ?

Cordialement,

Je propose cette fonction :

Function getvaleur(a As Range)
 Application.Volatile True
 getvaleur = a.MergeArea.Cells(1, 1).Value
End Function

qui s'utilise ainsi :

=getvaleur(A2)

Bonjour xorsankukai,

Effectivement, ma solution ne respecte pas la demande initiale sur les autres cellules, mais j'étais parti sur le fait qu'il voulait fusionner l'ensemble des cellules et garder l'information de la cellule A1.

J'avoue ne pas avoir trop compris le passage des autres cellules qui prenaient la valeur de A1 sans être visible...

Dans cette optique, ta seconde solution me paraît être la plus judicieuse quant à la demande initiale.

En tout cas, merci pour ton retour !

19test.xlsm (29.37 Ko)

ok bon tant pis pour cette solution, merci quand même.

Alors je vous met on fichier sur lequel je butte, on ne sais jamais, vous pourrez peut-être résoudre mon problème:

La colonne BJ ne se met pas a jour automatiquement quand je fusionne, je suis obligée d'aller cliquer sur la cellule et valider. Eet-ce possible de l'automatiser?

La cellule K33 : je n'arrive pas a trouver une formule qui compterais tous le temps passé en Test1. (C'est à dire, en tenant compte de la fusion).

Pouvez-vous m'aider?

Bonjour,

J'ai trouvé une macro pour compter le nombre de cellule fusionnée mais ces fusions me pose problème pour d'autres formules.

Je ne comprends pas bien ce besoin de fusionner les cellules. Je serai curieux de voir le fichier (même sans données) que tu as construit. Car au-delà de cette difficulté de calcul, tu te prives d'un grand nombre de fonctionnalités et de "facilités". Ne serait-ce que travailler avec des TCD.

Edit : j'étais en train de t'écrire quand j'ai vu ton fichier ... je vais voir de mon côté quelques réponses déjà (toutes) faites si j'en ai.

C'est super gentil et moi j'essaie de tester les différentes solution que l'on m'a donné. En tout cas, merci de vous pencher sur mon problème.Je sais que la fusion n'est pas la bonne chose mais ce n'est pas lisible si on selectionne chaque menu en fonction du temps passé.

On pourrait adapter quelque chose comme ceci en modifiant les jours par des quarts d'heure...

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.

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,

Avec le fichier fourni, je comprends mieux la demande,

Compliqué....mais Steelson est sur l'affaire,

Cordialement,

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.

On peut continuer sur les 2 solutions avec xorsankukai

Je vais essayer de faire une adaptation assez simple du fichier que je t'ai proposé.

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 ?

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

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

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, ).

27test.xlsm (30.53 Ko)

Cordialement,

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 ...

avec pour le gestionnaire-administrateur un outil de création des userform qui lui nécessite l'accès approuvé ...

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
Rechercher des sujets similaires à "fusion copie valeur"