Discussion :

[azerty1956]

oui je vois ca
pas de souci je te remercie pour ce que tu fais

[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.
@+

[azerty1956]

Salut casefayere, le forum,

Merci pour l'aide
Une fois que j'ai virer les chiffres de mon tableau le code marche très bien..Merci

J'ai une question concernant ce code :

Pour rendre le code plus général=> Est ce qu'on peut définir un nombre de blocs (contenant chacun 50 colonnes sauf le premier bloc qui représente les 3premières colonnes qui sera fixe) qui dépendra du nombre de colonnes renseignées dans le Tableau. (définir un compteur de colonnes ?)
Du style :
(le premier bloc est tjr fixe c'est celui où il y a que les 3premières colonnes pour les autres blocs voir ci-dessous)
si 0<nbre de colonnes renseignées<50 => définir un bloc 1
si 51<nbre de colonnes renseignées<101 => définir un bloc 1 & 2
si 102<nbre de colonnes renseignées<152 => définir un bloc 1 & 2 & 3
si 153<nbre de colonnes renseignées< 203 => définir un bloc 1 & 2 & 3 & 4
si 204<nbre de colonnes renseignées<254 => définir un bloc 1 & 2 & 3 & 4 & 5
Je pense même qu'on peut faire quelquechose de plus général que les conditions que je viens d'émettre...

Qu'est ce que vous pensez de tout ca ?

[casefayere]

Bonjour Azerty, le forum,

Si j'ai bien compris, tu peux définir ton nombre de blocs au départ, avec un code du genre :

Code :

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

nbblocs = INT((ActiveSheet.UsedRange.Columns.Count-3)/50)+2 'si la division retourne une décimale

à vérifier, la fonction INT, peut-être application.worksheetfunction.INT

A +

[azerty1956]

Voila le petit code que je viens d'essayer :
J'ai mis des conditions sur le nbre de blocs, le problème est que je veux que le dernier bloc s'arrête au niveau de la dernière colonne renseignée, j'ai fais ca dans le code mais ca ne marche pas, en fait je ne sais pas comment faire pour corriger le tir?

Code :

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

1
2
f = "" & "=sheet1!R" & deb(x) & "C56:R" & fin(x) & "C& ActiveSheet.UsedRange.Columns.Count" & ""
ActiveWorkbook.Names.Add Name:="sheet1" & separ & 2, RefersToR1C1:=f

ou :

Code :

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

1
2
f = "" & "=sheet1!R" & deb(x) & "C56:R" & fin(x) & "DerniereColonne" & ""
ActiveWorkbook.Names.Add Name:="sheet1" & separ & 2, RefersToR1C1:=f

le code complet :

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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
Sub test2()
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 DerniereColonne As Integer
Dim nbblocs As Integer
Dim mysheet As Worksheet
Set mysheet = Sheets("sheet1")
 
 DerniereLigne = ActiveSheet.Range("D65536").End(xlUp).Row
 DerniereColonne = ActiveSheet.Range("IV1").End(xlToLeft).Column
'*****************************************************************************************************
'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 '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, "-", "_")
 
nbblocs = Int((ActiveSheet.UsedRange.Columns.Count - 4) / 50) + 2 'si la division retourne une décimale
 
If nbblocs = 2 Then
f = "" & "=sheet1!R" & deb(x) & "C1:R" & fin(x) & "C3" & ""
ActiveWorkbook.Names.Add Name:="sheet1" & separ, RefersToR1C1:=f
'A ce niveau la, ca ne marche plus quand je mets DerniereColonne au lieu de C55
f = "" & "=sheet1!R" & deb(x) & "C5:R" & fin(x) & "DerniereColonne" & ""
ActiveWorkbook.Names.Add Name:="sheet1" & separ & 1, RefersToR1C1:=f
End If
If nbblocs = 3 Then
 
f = "" & "=sheet1!R" & deb(x) & "C1:R" & fin(x) & "C3" & ""
ActiveWorkbook.Names.Add Name:="sheet1" & separ, RefersToR1C1:=f
 
f = "" & "=sheet1!R" & deb(x) & "C5:R" & fin(x) & "C55" & ""
ActiveWorkbook.Names.Add Name:="sheet1" & separ & 1, RefersToR1C1:=f
'A ce niveau la, ca ne marche plus quand je mets DerniereColonne au lieu de C106
f = "" & "=sheet1!R" & deb(x) & "C56:R" & fin(x) & "DerniereColonne" & ""
ActiveWorkbook.Names.Add Name:="sheet1" & separ & 2, RefersToR1C1:=f
End If
 
If nbblocs = 4 Then
 
f = "" & "=sheet1!R" & deb(x) & "C1:R" & fin(x) & "C3" & ""
ActiveWorkbook.Names.Add Name:="sheet1" & separ, RefersToR1C1:=f
 
f = "" & "=sheet1!R" & deb(x) & "C5:R" & fin(x) & "C55" & ""
ActiveWorkbook.Names.Add Name:="sheet1" & separ & 1, RefersToR1C1:=f
 
f = "" & "=sheet1!R" & deb(x) & "C56:R" & fin(x) & "C106" & ""
ActiveWorkbook.Names.Add Name:="sheet1" & separ & 2, RefersToR1C1:=f
 
f = "" & "=sheet1!R" & deb(x) & "C107:R" & fin(x) & "DerniereColonne" & ""
ActiveWorkbook.Names.Add Name:=separ & 3, RefersToR1C1:=f
 
End If
 
If nbblocs = 5 Then
 
f = "" & "=sheet1!R" & deb(x) & "C1:R" & fin(x) & "C3" & ""
ActiveWorkbook.Names.Add Name:="sheet1" & separ, RefersToR1C1:=f
 
f = "" & "=sheet1!R" & deb(x) & "C5:R" & fin(x) & "C55" & ""
ActiveWorkbook.Names.Add Name:="sheet1" & separ & 1, RefersToR1C1:=f
 
f = "" & "=sheet1!R" & deb(x) & "C56:R" & fin(x) & "C106" & ""
ActiveWorkbook.Names.Add Name:="sheet1" & separ & 2, RefersToR1C1:=f
 
f = "" & "=sheet1!R" & deb(x) & "C107:R" & fin(x) & "C157" & ""
ActiveWorkbook.Names.Add Name:=separ & 3, RefersToR1C1:=f
 
f = "" & "=sheet1!R" & deb(x) & "C158:R" & fin(x) & "DerniereColonne" & ""
ActiveWorkbook.Names.Add Name:=separ & 4, RefersToR1C1:=f
 
End If
 
If nbblocs = 6 Then
 
f = "" & "=sheet1!R" & deb(x) & "C1:R" & fin(x) & "C3" & ""
ActiveWorkbook.Names.Add Name:="sheet1" & separ, RefersToR1C1:=f
 
f = "" & "=sheet1!R" & deb(x) & "C5:R" & fin(x) & "C55" & ""
ActiveWorkbook.Names.Add Name:="sheet1" & separ & 1, RefersToR1C1:=f
 
f = "" & "=sheet1!R" & deb(x) & "C56:R" & fin(x) & "C106" & ""
ActiveWorkbook.Names.Add Name:="sheet1" & separ & 2, RefersToR1C1:=f
 
f = "" & "=sheet1!R" & deb(x) & "C107:R" & fin(x) & "C157" & ""
ActiveWorkbook.Names.Add Name:=separ & 3, RefersToR1C1:=f
 
f = "" & "=sheet1!R" & deb(x) & "C158:R" & fin(x) & "C208" & ""
ActiveWorkbook.Names.Add Name:=separ & 4, RefersToR1C1:=f
 
f = "" & "=sheet1!R" & deb(x) & "C209:R" & fin(x) & "DerniereColonne" & ""
ActiveWorkbook.Names.Add Name:=separ & 5, RefersToR1C1:=f
 
End If
 
Next x
Set mysheet = Nothing
 
End Sub

Je pense qu'il y a moyen d'améliorer ce code de facon significative, il est assez rigide car il s'arrete au niveau nb bloc =6 mais je pense que dans mon cas ca ira...

voila voila

[casefayere]

C'est dommage, je n'ai pas ton fichier sous les yeux et j'ai un après-midi chargé, mais, rien que ça:

Code :

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

C& ActiveSheet.UsedRange.Columns.Count

ne peut pas fonctionner remplacer par

Code :

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

"C" & ActiveSheet.UsedRange.Columns.Count

Si tu ne t'en sors pas, je pourrais regarder ce soir

[azerty1956]

Impeccable ca marche
je te tiens au courant pour les améliorations que je vais faire sur le code
merci

Finalement, je viens de m'apercevoir que ca me serait très pratique de pouvoir affecter un nom de bloc à une zone où il n y a que des valeurs numériques
est ce que tu as une idée pour faire cela?

[casefayere]

Bonsoir Azerty,

Là, il va falloir que tu m'expliques car je n'ai qu'un bout de feuille sans valeur numérique ,peut-être peux-tu envoyer un projet un peu plus étoffé avec des explications.

Bonne soirée

[azerty1956]

Bonjour casefayere,

Voila un tableau bien étoffé
avec une colonne D cachée ou il y a des concaténations, cette colonne est utilisée pour faire un find et pouvoir remplir mon tableau...
Voila pour la création des blocs ca a l air de marcher même pour les chiffres, mais par contre ca ne s'arrete pas à la dernière colonne renseignée (comme c'est demandé dans le code)

Voila voila
Merci beaucoup pour l'aide

[azerty1956]

+ de précisions :

En réalité le nombre de mes colonnes est largement + important
idem pour le nombre de lignes

Je souhaite créer des noms de blocs pour pouvoir faire appel à eux lors de l'impression de mon tableau....
mon objectif est de faire des copier coller de chaque bloc dans une autre feuille cachée et par la suite les imprimer....J'ai déja le code pour un tableau rigide où on définissait des blocs à la main, mais dans mon cas mon tableau est dynamique c'est pour cela que je veux coder cette partie de "définition des noms de blocs" ...
j'espère que mon objectif est clair
si tu as une autre idée pour l'impression d'un grand tableau excel n'hesite pas à me tenir au courant..

NB : après l'impression de mes tableaux, je vais avoir à peu près 25 pages

Voila voila

@ toute

[casefayere]

Bonjour Azrty,

Ce qui était préparé jusque maintenant était pour arréter tes blocs toutes les 50 colonnes (à part la les 3 premières).

1- je ne suis pas sur qu'un bloc tienne sur une page
2- à chaque page, tu vas retrouver des catégories qui ne seront pas entières
3- Passer par des sauts de pages, ne serait'il pas préférable que de définir des blocs
4- ne veux-tu pas imprimer une ou plusieurs pages (suivant le nombre de colonnes) par catégorie
a +

[azerty1956]

ReBonjour,

1- je ne suis pas sur qu'un bloc tienne sur une page

justement d'ou l'interet de créer plusieurs blocs
par exemple mon premier tableau sera composé de METIER METIER1
mon 2ème tableau sera composé de METIER METIER2
mon 3ème tableau sera composé de METIER METIER3

et j'ai défini dans mon vrai tableau des blocs Head ou j'ai la 1ère et 2ème ligne
et qui fera partie des tableaux, exemple :

Head1
METIER METIER1


2- à chaque page, tu vas retrouver des catégories qui ne seront pas entières
Pour les catégories si elles ne sont pas entière cpa grave
par contre les activités doivent être complete a savoir ne pas couper le tableau au milieu d'une activité (pour ne pas paumer les sous activités de l activité )


3- Passer par des sauts de pages, ne serait'il pas préférable que de définir des blocs
Je ne vois pas comment ?
A ce moment ne faudrait il pas préciser à partir de quel partie du tableau faut faire le saut de page ?

4- ne veux-tu pas imprimer une ou plusieurs pages (suivant le nombre de colonnes) par catégorie
Je veux "caser" le max de colonnes par page de facon à ce que ca soit lisible, dou le fait que je t avais dis précedemment que il fallait définir 50 colonnes par pages ( pr 50 colonnes ca me parait lisible)

[casefayere]

Ok, je vais suivre ta logique mais essayer de soulager le code, a peut me prendre du temps (je ne suis pas un grand nerveux) et je autre chose à coté

J'espère que tu n'es pas pressé

a +

[azerty1956]

je comprends tout a fait que ta bcp de chose à faire, je te remercie pour ton aide qui m'a permis de pa mal avancer...
Moi de mon coté je suis dessus et je resterais un bon bout de temps, l'impression me parait comme une grosse problématique, je te tiendrais au courant de l'avancé

Merci
et @+

[casefayere]

J'aimerais que tu testes cette procédure, en entier

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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
Option Explicit
Option Base 1 'n'oublies pas ça
Sub Bloc()
Dim x As Integer, f As String, z As Integer, deb() As Integer, fin() As Integer, y As Integer, s As Integer
Dim separ As String
Dim DerniereLigne As Integer
Dim DerniereColonne As Integer
Dim nbblocs As Integer
Dim mysheet As Worksheet 'ça, je ne vois pas l'utilité
Set mysheet = Sheets("sheet1") 'ça, je ne vois pas l'utilité
 
 DerniereLigne = ActiveSheet.Range("D65536").End(xlUp).Row
 DerniereColonne = ActiveSheet.Range("IV1").End(xlToLeft).Column
'**************************************************************
nbblocs = Int((DerniereColonne - 4) / 50) + 2 'si la division retourne une décimale
'***************************************************************
 
'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 ' 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
'*************************************************************************
'pour le premier bloc car tu en aura 1 d'office
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" & ""
ActiveWorkbook.Names.Add Name:="sheet1" & separ, RefersToR1C1:=f
Next x
'******************************************************************
'pour le deuxième bloc car tu en aura 1 d'office
For x = 1 To UBound(deb, 1) - 1
separ = Application.WorksheetFunction.Substitute(Range("a" & deb(x)).Value, "-", "_")
f = "" & "=sheet1!R" & deb(x) & "C5:R" & fin(x) & "C55" & ""
ActiveWorkbook.Names.Add Name:="sheet" & "2" & separ, RefersToR1C1:=f
Next x
'***************************************************************************
'pour le reste
For y = 56 To DerniereColonne Step 50
s = 3
For x = 1 To UBound(deb, 1) - 1
separ = Application.WorksheetFunction.Substitute(Range("a" & deb(x)).Value, "-", "_")
f = "" & "=sheet1!R" & deb(x) & "C" & y & ":R" & fin(x) & "C" & y + 50 & ""
ActiveWorkbook.Names.Add Name:="sheet" & s & separ, RefersToR1C1:=f
Next x
s = s + 1
Next y
Set mysheet = Nothing 'ça, je ne vois pas l'utilité
 
End Sub