Discussion :

[azerty1956]

Salut tout le monde,

J’ai un grand tableau que je génère grâce à des macros, une centaine de colonne et plus que 300 lignes.
Je me focalise dans un premier temps sur la partie des 3 premières colonnes.
Si vous consultez le tableau ci-joint, vous verrez que pour chaque activité correspond une panoplie de sous activités et sous sous activités.
Pour avoir une idée plus précise de ce que je veux faire voir le tableau Excel joint, et voir dans le Insertion/Nom/définir vous verrez alors les noms que j’ai définis pour chaque groupe.
Je souhaite en effet automatiser cela, car mon tableau change régulièrement.

Je souhaite définir un nom sur Excel pour chaque Activité (on inclus aussi ses sous activités dans la séléction)
Pour cela J’ai le code suivant mais je ne sais pas quoi faire pour créer un nom pour chaque activité et ses sous activités (je fais cela pour copier dans un deuxième temps ce bloc dans une autre feuille et l’imprimer)

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
Sub CréationBlocImpression()
 
Dim i As Integer
Dim imax As Integer
Dim act As String
 
Dim currStartLine As Integer
Dim currLastLine As Integer
Dim mysheet As Worksheet
 
 Set mysheet = Sheets("sheet1")
 
mysheet.Select
 
imax = mysheet.Range("D65536").End(xlUp).Row
currStartLine = 4
currLastLine = 4
 
While currLastLine < imax
 
        currLastLine = Application.WorksheetFunction.Min(mysheet.Range("A" & currStartLine).End(xlDown).Row - 1, imax)
        Range(Cells(currStartLine, 1), Cells(currLastLine, 3)).Select
       'J’ai un problème au niveau de la ligne de code qui suit         
       ActiveWorkbook.Names.Add Name:="METIER" 
        currStartLine = currLastLine + 2
 
Wend
 
Set mysheet = Nothing
 
End Sub

Voir la ligne après le commentaire dans le code.

PS : le tableau ne représente qu’un exemple mon vrai tableau est largement plus grand d’où l’intérêt de la manipe ( dans l'exemple je n'ai pris qu'une petite partie des 3 premières colonnes sans prendre la première ligne ni le contenu du tableau).

Ce que je souhaite coder est :
Dès que l’on trouve une cells(i,1) non vide alors stocker son nom et séléctionner les 3 colonnes A,B,C jusqu’au niveau de la dernière cells(i,1) vide (juste avant l’activité d’après).
Le nom stocké sera celui qu’on définira comme nom pour la sélection.


Merci à tout ceux qui vont prendre de leurs temps pour participer a cette discussion

[casefayere]

Bonsoir,
j'ai fait des essais avec des boucles mais je ne trouve encore pas la solution,

Par contre, pour ta ligne d'erreur, ce code peut peut-etre t'aider

Code :

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

1
2
        f = "" & "=Sheet1!R" & x & "C1:R" & lg & "C3" & ""
        ActiveWorkbook.Names.Add Name:=Range("a" & x).Value, RefersToR1C1:=f

ou f est variable string, x variable integer et lg variable integer

J'ai essayé avec le test de la couleur

Code :

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

If Range("c" & x).Interior.ColorIndex = 41 ....'ta couleur bleue

je suis près du but mais ça coince encore

a +

[azerty1956]

Merci casefayere je suis en train de chercher de mon coté aussi
je test tout de suite ce que tu m'as corrigé
j'aurais jamais pensé à la couleur pour faire ma selection
a +

[casefayere]

ça y est, adaptes ce code

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
Option Explicit
Option Base 1
 
Sub test()
Dim x As Integer, f As String, z As Integer, deb(6) As Integer, fin(6) As Integer 'nombre à voir (6)
'*****************************************************************************************************
'alimente les deux tableaux debut et fin des noms à définir
z = 1
deb(1) = 2
For x = 3 To ActiveSheet.UsedRange.Rows.Count
If Range("c" & x).Interior.ColorIndex = 41 Then
deb(z + 1) = Range("c" & x).Row
fin(z) = Range("c" & x - 1).Row
z = z + 1
End If
Next x
fin(z) = ActiveSheet.UsedRange.Rows.Count
For x = 1 To 6
f = "" & "=Sheet1!R" & deb(x) & "C1:R" & fin(x) & "C3" & ""
ActiveWorkbook.Names.Add Name:=Range("a" & deb(x)).Value, RefersToR1C1:=f
Next x
End Sub

bonne nuit

Je viens d'améliorer pour les tableaux en les rendant dynamiques,

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
Option Explicit
Option Base 1'penser à mettre cette option
 
Sub test()
Dim x As Integer, f As String, z As Integer, deb() As Integer, fin() As Integer 'tableau dynamique
'*****************************************************************************************************
'alimente les deux tableaux debut et fin des noms à définir
z = 1
ReDim deb(2) 'change la taille
ReDim fin(2) 'change la taille
deb(1) = 2
For x = 3 To ActiveSheet.UsedRange.Rows.Count
If Range("c" & x).Interior.ColorIndex = 41 Then
deb(z + 1) = Range("c" & x).Row
fin(z) = Range("c" & x - 1).Row
z = z + 1
ReDim Preserve deb(z + 1) 'change la taille et préserve les données
ReDim Preserve fin(z + 1)'change la taille et préserve les données
End If
Next x
fin(z) = ActiveSheet.UsedRange.Rows.Count
For x = 1 To 6
f = "" & "=Sheet1!R" & deb(x) & "C1:R" & fin(x) & "C3" & ""
ActiveWorkbook.Names.Add Name:=Range("a" & deb(x)).Value, RefersToR1C1:=f
Next x
End Sub

[azerty1956]

Salut casefayere,
Merci pour l'aide, le code marche bien mais, je me suis heurté à un problème lié au fait que quelques unes de mes activités sont nommés avec des noms composés, la présence du tiret ne permet pas l’exécution du code comme il faut.
Toutes mes activités ont des noms où il y a plus de 4 lettres avant le tiret, est ce qu’il y a une possibilité de tronquer le nom est nommer la sélection avec les 4 premières lettres.

Deuxième question je souhaite faire le même code pour les colonnes 4 a 100 et 101 à 200
La partie à changer est bien cette ligne du code :

Code :

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

f = "" & "=Sheet1!R" & deb(x) & "C4:R" & fin(x) & "C100" & ""

Est ce que c’est possible d’appeler cette sélection avec le même nom de la sélection des 3 colonnes précédentes avec un 1 devant (activité tronquée1)
Et faire la même chose (activité tronquée2) pour les colonnes 101 à 200

En fait je ne vois pas à quel niveau du code tu défini le nom de la sélection?

Merci d'avance
@+

[casefayere]

Bonjour Azerty,

Pour la prmière partie,

Toutes mes activités ont des noms où il y a plus de 4 lettres avant le tiret, est ce qu’il y a une possibilité de tronquer le nom est nommer la sélection avec les 4 premières lettres.

le code

Code :

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

ActiveWorkbook.Names.Add Name:=Left(Range("a" & deb(x)).Value, 4), RefersToR1C1:=f

Pour la deuxième, je vais regarder avant de dire des bétises,

Code :

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

f = "" & "=Sheet1!R" & deb(x) & "C4:R" & fin(x) & "C100" & ""

me parait correct

Est ce que c’est possible d’appeler cette sélection avec le même nom de la sélection des 3 colonnes précédentes avec un 1 devant (activité tronquée1)
Et faire la même chose (activité tronquée2) pour les colonnes 101 à 200

là, ça peut être simple si les lignes en bleue sont toujours les memes a2:100...

Code :

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

ActiveWorkbook.Names.Add Name:=Left(Range("a" & deb(x)).Value, 4), RefersToR1C1:=f

en incrementant une variable avant chaque boucle

le nom de la selection est bien là

Code :

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

ActiveWorkbook.Names.Add Name:=Left(Range("a" & deb(x)).Value, 4), RefersToR1C1:=f

a +

[azerty1956]

Merci pour la réponse casefayere.

la couleur des lignes est tjr la même donc il n y a pas de souci a ce sujet.

Est ce que c'est possible d'appeler la selection Colonne 4 à 100 activité1?
(mettre un 1 devant le nom de la selection et un 2 devant le nom de la selection pour les colonnes 101 à 200)

Au lieu de tronquer l'activité je viens de trouver une fonction pour m'enlever les petit tiret :

Code :

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

1
2
3
4
5
6
7
8
9
Sub test3()
Dim mystr As String
Dim separ As String
mystr = "ARB-EUR"
separ = "-"
 
mystr = GetRidOfCharacter(separ, mystr)
 
End Sub

"Ca peut etre plus intéressan d'utiliser cette fonction que tronquer"
quoique je ne vois pas comment je pourrais l'utiliser dans mon cas

[casefayere]

Je viens de concocter un code mais, il faut se rappeler que les noms commençant par un chiffre ne sont pas acceptés, ne veux-tu pas passer ton chifre après, ça donnerait ce code

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
Option Base 1
 
Sub test()
Dim x As Integer, f As String, z As Integer, deb() As Integer, fin() As Integer, _
cold As Integer, colf As Integer, mes As Range, ch As String
'*****************************************************************************************************
'alimente les deux tableaux debut et fin des noms à définir
z = 1
ReDim deb(2)
ReDim fin(2)
deb(1) = 2
For x = 3 To ActiveSheet.UsedRange.Rows.Count
If Range("a" & x).Interior.ColorIndex = 41 Then
deb(z + 1) = Range("a" & x).Row
fin(z) = Range("a" & x - 1).Row
z = z + 1
ReDim Preserve deb(z + 1)
ReDim Preserve fin(z + 1)
End If
Next x
fin(z) = ActiveSheet.UsedRange.Rows.Count
Set mes = Application.InputBox("Choix de cellule(s)", Type:=8) 'message pour choisir le départ
If mes.Column < 4 Then: cold = 1: colf = 3: ch = ""
If mes.Column >= 4 Then: cold = 4: colf = 100: ch = "1"
If mes.Column > 100 Then: cold = 101: colf = 200: ch = "2"
 
For x = 1 To 6
f = "" & "=Sheet1!R" & deb(x) & "C" & cold & ":R" & fin(x) & "C" & colf & ""
ActiveWorkbook.Names.Add Name:=Left(Range("a" & deb(x)).Value, 4) & ch, RefersToR1C1:=f
Next x
End Sub

je viens d'essayer ton code

Code :

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

1
2
3
4
5
6
7
For x = 1 To 6
f = "" & "=Sheet1!R" & deb(x) & "C" & cold & ":R" & fin(x) & "C" & colf & ""
mystr = Range("a" & deb(x)).Value
separ = "-"
mystr = GetRidOfCharacter(separ, mystr)
 
ActiveWorkbook.Names.Add Name:=mystr & ch, RefersToR1C1:=f

vba ne reconnait pas la fonction GetRidOfCharacter

ne vaudrait'il pas mieux de passer par un "replace"

code avec "replace"

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
Option Explicit
Option Base 1
 
Sub test()
Dim x As Integer, f As String, z As Integer, deb() As Integer, fin() As Integer, _
cold As Integer, colf As Integer, mes As Range, ch As String, separ As String
 
'*****************************************************************************************************
'alimente les deux tableaux debut et fin des noms à définir
z = 1
ReDim deb(2)
ReDim fin(2)
deb(1) = 2
For x = 3 To ActiveSheet.UsedRange.Rows.Count
If Range("a" & x).Interior.ColorIndex = 41 Then
deb(z + 1) = Range("a" & x).Row
fin(z) = Range("a" & x - 1).Row
z = z + 1
ReDim Preserve deb(z + 1)
ReDim Preserve fin(z + 1)
End If
Next x
fin(z) = ActiveSheet.UsedRange.Rows.Count
Set mes = Application.InputBox("Choix de cellule(s)", Type:=8) 'message pour choisir le départ
If mes.Column < 4 Then: cold = 1: colf = 3: ch = ""
If mes.Column >= 4 Then: cold = 4: colf = 100: ch = "1"
If mes.Column > 100 Then: cold = 101: colf = 200: ch = "2"
For x = 1 To 6
separ = Replace(Range("a" & deb(x)).Value, "-", "_")
f = "" & "=Sheet1!R" & deb(x) & "C" & cold & ":R" & fin(x) & "C" & colf & ""
ActiveWorkbook.Names.Add Name:=separ & ch, RefersToR1C1:=f
Next x
End Sub

[azerty1956]

Salut casefayere,

je viens d'essayer le code mais il y a un grand bug au niveau de la message box.

Est ce qu'on ne peut pas lui dire de commencer automatiquement à partir de la cells(2,1)?

Problème à ce niveau la :

Code :

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

Set mes = Application.InputBox("Choix de cellule(s)", Type:=8) 'message pour choisir le départ

[casefayere]

Je ne comprends pas le bug, chez moi, ça marche, est-ce que c'est une question de version

as-tu compris que ce message te permet d'avoir la main sur la cellule à choisir ?

sinon, il faut encore réfléchir car quels repère vont permettre de passer de 4 à 100, 101 à 200, on peut mais c'est plus de codes

[azerty1956]

est ce qu'on ne peut pas prendre comme repère le numéro de la colonne ?

[casefayere]

ça doit etre possible en imbriquant un autre boucle au dessus de la premiere et dans ce cas plus besoin d'inputbox

[azerty1956]

resalut casefayere,

je ne vois pas pourquoi il faut faire une autre boucle alors qu'au début de notre discussion il suffisai de faire ca ??

Code :

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

f = "" & "=Sheet1!R" & deb(x) & "C4:R" & fin(x) & "C100" & ""

je les testé comme ca et ça marche au niveau du premier code
est ce qu'on ne peut pas imbriquer cela dans le nouveau code ?

[casefayere]

Je repensai à ton code, si tu as essayé de l'adapter à ton fichier réel, c'est normal que ça ne fonctionne pas car il faut changer cette ligne

Code :

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

For x = 1 To 6

pour

Code :

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

For x = 1 To UBound(deb, 1)-1

car tu as certainement beaucoup plus de lignes

Bonne soirée

[azerty1956]

Oui tu as completement raison la dessus
voila la version du code utilisé, il y a des bugs par contre

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
Sub test()
Dim x As Integer, f As String, z As Integer, deb() As Integer, fin() As Integer
Dim separ As String
Dim DerniereLigne As Integer
Dim sheet As Worksheet
Set sheet = Sheets("sheet1")
 
 DerniereLigne = sheet.Range("D65536").End(xlUp).Row
'*****************************************************************************************************
'alimente les deux tableaux debut et fin des noms à définir
z = 1
ReDim deb(2)
ReDim fin(2)
deb(1) = 3
 
For x = 3 To DerniereLigne
If Range("a" & x).Interior.ColorIndex = 48 Then
deb(z + 1) = Range("a" & x).Row
fin(z) = Range("a" & x - 1).Row
z = z + 1
ReDim Preserve deb(z + 1)
ReDim Preserve fin(z + 1)
End If
Next x
fin(z) = DerniereLigne
For x = 1 To UBound(deb, 1) - 1
separ = Replace(Range("a" & deb(x)).Value, "-", "")
f = "" & "=sheet1!R" & deb(x) & "C1:R" & fin(x) & "C3" & ""
'Bug a ce niveau la
ActiveWorkbook.Names.Add Name:=Range("a" & deb(x)).Value, RefersToR1C1:=f
f = "" & "=sheet1!R" & deb(x) & "C4:R" & fin(x) & "C50" & ""
'quand je force le code ca me fais un bug a ce niveau la aussi
ActiveWorkbook.Names.Add Name:=Range("a" & deb(x)).Value & 1, RefersToR1C1:=f
f = "" & "=sheet1!R" & deb(x) & "C50:R" & fin(x) & "C90" & ""
'idem, un bug ici aussi 
ActiveWorkbook.Names.Add Name:=Range("a" & deb(x)).Value & 2, RefersToR1C1:=f
 
Next x
Set sheet = Nothing
 
End Sub

un msg box me dit : Name invalid

[casefayere]

Bon, j'ai copié ton code mais changé dernierligne car je n'ai rien en D

Code :

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

DerniereLigne = ActiveSheet.UsedRange.Rows.Count 'moi je suis obligé de garder ce code car rien en D

j'ai aussi changé le code couleur qui n'est pas le meme que chez moi

Code :

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

If Range("a" & x).Interior.ColorIndex = 41 Then 'là je remets mon code couleur

et j'ai lancé la macro, pas de problème
conclusion, le problème vien soit de ta colonne D (je ne sais pas ce qui s'y passe) soit d'une autre colonne que je n'ai pas

a + bon courage
mais continues à me tenir au courant

[azerty1956]

salu casefayere,

si tu le fais pour C :

Code :

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

DerniereLigne = sheet.Range("C65536").End(xlUp).Row

Le problème viens surement du replace : essaye en mettant un nom composé dans le tableau et tu verras, je pense que c'est à cause de ça que ça ne marche pas

[casefayere]

J'ai essayé, meme avec C pour atteindre la derniere ligne, aucun problème mais peut-etre que tu as des noms en A ou D ou la 101eme colonne qui sont composés mais avec un espace, ou encore commençant par un chiffre, les définitions de nom ne supportent pas non plus les espaces et ne peuvent commencer par un chiffre mais ça, je te l'ai déjà dit

sinon, je ne vois pas vu que chez moi, ça fonctionne

J'espere que tu résoudras le problème et tiens moi toujours au courant

Bonne soirée

Je regardais encore ton nouveau code et me suis aperçu que tu as fait une erreur avec replace

Code :

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

separ = Replace(Range("a" & deb(x)).Value, "-", "")

replce n'aime pas ça, laisse le "_" et ça ira

C'est normal que pour moi ça fonctionne, dans ton bout de fichier, pas de "-"

Peux-tu essayer ce code, j'y ai laissé tes commentaires et changer replace par substitute

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
Sub test()
Dim x As Integer, f As String, z As Integer, deb() As Integer, fin() As Integer
Dim separ As String
Dim DerniereLigne As Integer
Dim sheet As Worksheet
Set sheet = Sheets("sheet1")
 
 DerniereLigne = ActiveSheet.Range("C65536").End(xlUp).Row 'moi je suis obligé de garder ce code car rien en D
'*****************************************************************************************************
'alimente les deux tableaux debut et fin des noms à définir
z = 1
ReDim deb(2)
ReDim fin(2)
deb(1) = 3
 
For x = 3 To DerniereLigne
If Range("a" & x).Interior.ColorIndex = 41 Then 'là je remets mon code couleur
deb(z + 1) = Range("a" & x).Row
fin(z) = Range("a" & x - 1).Row
z = z + 1
ReDim Preserve deb(z + 1)
ReDim Preserve fin(z + 1)
End If
Next x
'****************************************************
fin(z) = DerniereLigne
For x = 1 To UBound(deb, 1) - 1
separ = Application.WorksheetFunction.Substitute(Range("a" & deb(x)).Value, "-", "")
f = "" & "=sheet1!R" & deb(x) & "C1:R" & fin(x) & "C3" & ""
'Bug a ce niveau la
ActiveWorkbook.Names.Add Name:=separ, RefersToR1C1:=f
f = "" & "=sheet1!R" & deb(x) & "C4:R" & fin(x) & "C50" & ""
'quand je force le code ca me fais un bug a ce niveau la aussi
ActiveWorkbook.Names.Add Name:=separ & 1, RefersToR1C1:=f
f = "" & "=sheet1!R" & deb(x) & "C50:R" & fin(x) & "C90" & ""
'idem, un bug ici aussi
ActiveWorkbook.Names.Add Name:=separ & 2, RefersToR1C1:=f
 
Next x
Set sheet = Nothing
 
End Sub

[azerty1956]

Salut casefayere,

Je suis vraiment désolé, je suis très con, en fait la partie de la colonne 5 à 90 est remplie par des valeurs numériques
Vraiment dsl j'ai zappé ça....
Comment on peut faire à ce moment la ?

j'ai finalement une piste, j'ai pas Excel la, mais Lundi, je te tiens au courant quand j'aurais fait ce test.
@+

[casefayere]

Bonsoir Azerty ,re le forum,

Je viens de m'apercevoir d'une bourde formidable avec ce que tu voudrais pour les en-têtes en décalant de 50 colonnes,

au hasard, cette formule ne peut pas marcher

Code :

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

RefersToR1C1:="=sheet1!R1C5:R2C55"

pour la bonne raison que sur ta ligne 1, ce sont des cellules fusionnées donc le nom attribué va jusqu'au bout de la cellule fusionnée, ça fausse complétement mon raisonnement que je croyais au point pour t'aider à nommer ces plages

aye aye aye, là je vais caler

bonne nuit