fusion cellule après automatisation des ajout via UserForm VBA

Version imprimable

3 pièce(s) jointe(s)

Bonjour

J'ai développé une application via VBA et tout fonctionne correctement, toutefois pour plus de clarté je souhaitais mettre en forme les cellules après l'ajout dans la feuille.

Voila se que j'ai fais mais je n'arrive pas a automatiser le formatage sur tous les ajouts

Code:

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
Sub Addme()
'***********************************************************************************
'Procédure permettant de rajouter la ligne de données dans le FTU
'************************************************************************************
    Set NextRow = Sheets("Contact").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
 
 
    For X = 1 To Cnum
        NextRow = Me.Controls(Ref & X).Value ' On récupère les valeurs des controls
        Set NextRow = NextRow.Offset(0, 1) ' on les insères dans la colonnes
 
    Next X
 
    Range("I11:K11").Select
    Range("K11").Activate
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
 
End Sub

Pièce jointe 383265
Pièce jointe 383266
Pièce jointe 383270

merci de votre aide!

Bonjour,

Si j'ai bien compris ta demande tu auras besoin d'un code de ce type :

Code:

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
Dim NextRow As Range
nblig = Sheets("Contact").Cells(Rows.Count, 2).End(xlUp).Row
Set NextRow = Sheets("Contact").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
For X = 1 To Cnum
NextRow = 5 ' On récupère les valeurs des controls
Set NextRow = NextRow.Offset(0, 1) ' on les insères dans la colonnes
Next X
 
With Range(Cells(nblig, 2) & ":" & Cells(nblig, Cnum))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
    With .Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
    .Merge
End With

A tester et à adapter.

J’espère l'avoir appliquer au bonne cellules, car ton Range("I11:K11").Select me donne des doutes.

Bonne journée :)

1 pièce(s) jointe(s)

Salut Merci pour ton retour, mais j'ai donné le mauvais sub ....:roll:

j'ai essayé d'appliquer le code sur le bon Sub mais cela ne fonctionne pas...

les variables ont été déclaré

Code:

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
 
 Sub Addme2()
'***********************************************************************************
'Procédure permettant de rajouter la ligne de données dans le FTU
'************************************************************************************
   'Déclaration des variables
 
Dim Cnum As Integer
Dim X As Integer
Dim NextRow As Range
Dim NextColumns As Range
Dim Ref As String
 
 
nblig = Sheets("F.T.U").Cells(11, Columns.Count).End(xlToLeft).Row
Set NextRow = Sheets("F.T.U").Cells(11, Columns.Count).End(xlToLeft).Offset(0, 3)
For X = 1 To Cnum
NextRow = Me.Controls(Ref & X).Value ' On récupère les valeurs des controls
Set NextRow = NextRow.Offset(0, 2) ' on les insères dans la colonnes
Next X
 
With Range(Cells(nblig, 2) & ":" & Cells(nblig, Cnum))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
    With .Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
    .Merge
End With
 
End Sub

Merci pour votre retour

Pièce jointe 383286

25/05/2018, 16h04
Wololol

Re,

J'avoue ne pas trop comprendre ton programme :

Ton nblig va toujours contenir 11, car tu prend la ligne 11 et tu compte le nombre de colonne, puis récupère la coordonnée de la ligne :aie:

De plus pourquoi que la ligne 11 ? Tu ne veux pas appliquer le style à chaque nouvelle ligne ?

Peux-tu expliquer vraiment comment tu insère tes données comme ça on pourra résoudre ton problème, je pense personnellement qu'on peut se passer de l'Offset qui complique un peu trop le programme

Bonne fin de journée :)
25/05/2018, 16h30
thibault.mourichon

3 pièce(s) jointe(s)

J'essaie de t'envoyer le fichier mais la taille dépasse la limite autorisé par le forum, mais en gros je fais une application pour mes techniciens, il doivent gerer l'avancement de leur chantier et facturer en fonction d'un pourcentage d'avancement.
une partie des données sont enregistré via un Userform et un second userform complète certaine données dans un même tableau

Pièce jointe 383341
Pièce jointe 383342
Pièce jointe 383346

tu peux essayer de télécharger le fichier depuis
https://drive.google.com/open?id=13d...zlDbPweOdfjaMU

En te remerciant

1 pièce(s) jointe(s)

Re,

Pour voir si j'ai bien compris ta demande je t'ai créer deux méthodes de copie et de modification de format (en conservant ton style d'insertion), je pense qu'il doit y en avoir de mieux mais voici :

Méthode 1:

Code:

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
Private Sub CommandButton1_Click()
Dim NextRow As Range
Cnum = 3 ' j'ai mis ça car je ne sais pas comment tu récupère la valeur
 
Set NextRow = Sheets("Feuil1").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
 
For X = 1 To Cnum
NextRow = "Test 1" 'Me.Controls(Ref & X).Value ' On récupère les valeurs des controls
With NextRow
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
    With .Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
 
 
    End With
End With
 
Set NextRow = NextRow.Offset(0, 1) ' on les insères dans la colonnes
 
Next X
 
End Sub

Méthode 2 :

Code:

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
Private Sub CommandButton2_Click()
Dim NextRow As Range
Cnum = 3
With Sheets("Feuil1").Range("A1") ' format de référence sauvegarder dans cette cellule
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
    With .Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
 
 
    End With
    End With
 
 
 
 
 
 
 
Set NextRow = Sheets("Feuil1").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0)
 
Range("A1").Copy 'on copie la cellule de ref
 
For X = 1 To Cnum
NextRow = "Test 2" 'Me.Controls(Ref & X).Value ' On récupère les valeurs des controls
 
NextRow.PasteSpecial xlPasteFormats
 
Set NextRow = NextRow.Offset(0, 1) ' on les insères dans la colonnes
 
Next X
 
End Sub

Et le petit fichier test pour voir si c'était ce que tu voulais

Bonne journée

28/05/2018, 08h26
thibault.mourichon

1 pièce(s) jointe(s)

Salut

Malheureusement cela ne marche pas j'ai bien remplacé les chaque éléments mais le formatage de la fusion ne se fait pas et je comprends pas d'ou vient mon erreur
Pièce jointe 383830

J'ai réussi a réduire la taille de mon fichier si tu veux jeter un coup d’œil.

en te remerciant

Re,

Remplace ta Sub Addme2 par celle-ci

Code:

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
Sub Addme2()
'***********************************************************************************
'Procédure permettant de rajouter la ligne de données dans le FTU
'************************************************************************************
Dim col As Integer
 
col = Sheets("F.T.U").Cells(12, Columns.Count).End(xlToLeft).Column + 1
MsgBox col
Set NextRow = Sheets("F.T.U").Cells(11, Columns.Count).End(xlToLeft).Offset(0, 3)
 
For X = 1 To Cnum
NextRow = Me.Controls(Ref & X).Value  ' On récupère les valeurs des controls
 
With NextRow
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
    With .Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent1
        .TintAndShade = 0.599993896298105
        .PatternTintAndShade = 0
    End With
End With
 
Set NextRow = NextRow.Offset(0, 1) ' on les insères dans la colonnes
Next X
 
Sheets("F.T.U").Range(Cells(11, col), Cells(11, NextRow.Column - 1)).Merge
 
End Sub

Tu aura ainsi la fusion que tu souhaitais.

J'ai ajouté une variable col qui récupère les coordonnées de la dernière colonne remplie, ainsi, on peut se servir de cette coordonnée et celle de la variable NextRow pour avoir la Range à fusionner.

Bonne journée :)

29/05/2018, 15h34
thibault.mourichon

Merci beaucoup cela fonctionne parfaitement!!!!!! c'est magique