oui je vois ca :)
pas de souci je te remercie pour ce que tu fais ;)
Version imprimable
oui je vois ca :)
pas de souci je te remercie pour ce que tu fais ;)
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
pourCode:For x = 1 To 6
car tu as certainement beaucoup plus de lignesCode:For x = 1 To UBound(deb, 1)-1
Bonne soirée
Oui tu as completement raison la dessus
voila la version du code utilisé, il y a des bugs par contre
un msg box me dit : Name invalidCode:
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
Bon, j'ai copié ton code mais changé dernierligne car je n'ai rien en D
j'ai aussi changé le code couleur qui n'est pas le meme que chez moiCode:DerniereLigne = ActiveSheet.UsedRange.Rows.Count 'moi je suis obligé de garder ce code car rien en D
et j'ai lancé la macro, pas de problèmeCode:If Range("a" & x).Interior.ColorIndex = 41 Then 'là je remets mon code couleur
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:koi:
salu casefayere,
si tu le fais pour C :
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 pasCode:DerniereLigne = sheet.Range("C65536").End(xlUp).Row
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
replce n'aime pas ça, laisse le "_" et ça iraCode:separ = Replace(Range("a" & deb(x)).Value, "-", "")
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:
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
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.
@+
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 :D
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 ?
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 :
à vérifier, la fonction INT, peut-être application.worksheetfunction.INTCode:nbblocs = INT((ActiveSheet.UsedRange.Columns.Count-3)/50)+2 'si la division retourne une décimale
A +
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?
ou :Code:
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
le code complet :Code:
1
2 f = "" & "=sheet1!R" & deb(x) & "C56:R" & fin(x) & "DerniereColonne" & "" ActiveWorkbook.Names.Add Name:="sheet1" & separ & 2, RefersToR1C1:=f
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...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
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
voila voila
C'est dommage, je n'ai pas ton fichier sous les yeux et j'ai un après-midi chargé, mais, rien que ça:
ne peut pas fonctionner remplacer parCode:C& ActiveSheet.UsedRange.Columns.Count
Si tu ne t'en sors pas, je pourrais regarder ce soirCode:"C" & ActiveSheet.UsedRange.Columns.Count
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?
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
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
+ 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
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 +
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)
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 +
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 @+
J'aimerais que tu testes cette procédure, en entier
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
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