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 :
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 !
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,
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.J'ai trouvé une macro pour compter le nombre de cellule fusionnée mais ces fusions me pose problème pour d'autres formules.
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,
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