Comment imprimer un grand tableau excel?

Version imprimable

Voir 40 message(s) de cette discussion en une page

1 pièce(s) jointe(s)

Comment imprimer un grand tableau excel?

Salut tout le monde,:D

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:

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

23/04/2009, 21h21
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:

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:

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

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

a +
23/04/2009, 22h27
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 +

ça y est, adaptes ce code

Code:

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

:yaisse2:
bonne nuit

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

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
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

24/04/2009, 10h34
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:

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
@+
24/04/2009, 10h50
casefayere

Bonjour Azerty,

Pour la prmière partie,

Citation:

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:

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:

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

me parait correct

Citation:

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:

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:

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

a +
24/04/2009, 11h09
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:

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

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:

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:

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:

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

24/04/2009, 14h57
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:

Set mes = Application.InputBox("Choix de cellule(s)", Type:=8) 'message pour choisir le départ
24/04/2009, 15h06
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
24/04/2009, 16h37
azerty1956

est ce qu'on ne peut pas prendre comme repère le numéro de la colonne ?
24/04/2009, 16h43
casefayere

ça doit etre possible en imbriquant un autre boucle au dessus de la premiere et dans ce cas plus besoin d'inputbox
24/04/2009, 16h48
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:

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 ?

tu as raison, essaies ce code

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
Sub test()
Dim x As Integer, f As String, z As Integer, deb() As Integer, fin() As Integer
 
'*****************************************************************************************************
'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
For x = 1 To 6
separ = Replace(Range("a" & deb(x)).Value, "-", "_")
f = "" & "=Sheet1!R" & deb(x) & "C1:R" & fin(x) & "C3" & ""
ActiveWorkbook.Names.Add Name:=Range("a" & deb(x)).Value, RefersToR1C1:=f
f = "" & "=Sheet1!R" & deb(x) & "C4:R" & fin(x) & "C100" & ""
ActiveWorkbook.Names.Add Name:=Range("a" & deb(x)).Value & 1, RefersToR1C1:=f
f = "" & "=Sheet1!R" & deb(x) & "C101:R" & fin(x) & "C200" & ""
ActiveWorkbook.Names.Add Name:=Range("a" & deb(x)).Value & 2, RefersToR1C1:=f
 
Next x
End Sub

j'ai essayé le code mais il y a un bug au niveau du separ.

Je n'ai pas tout compris dans ce code, je vais réessayer de le décortiquer comme ca je te poserai des questions ciblées.

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
J'ai fait quelques petits changements sur le code :
 
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 mysheet As Worksheet
Set mysheet = Sheets("sheet1")
 
 DerniereLigne = mysheet.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 = 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) = DerniereLigne
For x = 1 To 6
'Bug à ce niveau la ?
separ = Replace(Range("a" & deb(x)).Value, "-", "")
f = "" & "=Sheet1!R" & deb(x) & "C1:R" & fin(x) & "C3" & ""
ActiveWorkbook.Names.Add Name:=Range("a" & deb(x)).Value, RefersToR1C1:=f
f = "" & "=Sheet1!R" & deb(x) & "C4:R" & fin(x) & "C100" & ""
ActiveWorkbook.Names.Add Name:=Range("a" & deb(x)).Value & 1, RefersToR1C1:=f
f = "" & "=Sheet1!R" & deb(x) & "C101:R" & fin(x) & "C200" & ""
ActiveWorkbook.Names.Add Name:=Range("a" & deb(x)).Value & 2, RefersToR1C1:=f
 
Next x
Set mysheet = Nothing
 
End Sub

perso, j'ai retiré le separ, regardes bien mon dernier code

J'ai fais une con..., excuses-moi, je corrige tout de suite

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
Sub test()
Dim x As Integer, f As String, z As Integer, deb() As Integer, fin() As Integer, 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
For x = 1 To 6
separ = Replace(Range("a" & deb(x)).Value, "-", "_")
f = "" & "=Sheet1!R" & deb(x) & "C1:R" & fin(x) & "C3" & ""
ActiveWorkbook.Names.Add Name:=separ, RefersToR1C1:=f
f = "" & "=Sheet1!R" & deb(x) & "C4:R" & fin(x) & "C100" & ""
ActiveWorkbook.Names.Add Name:=separ & 1, RefersToR1C1:=f
f = "" & "=Sheet1!R" & deb(x) & "C101:R" & fin(x) & "C200" & ""
ActiveWorkbook.Names.Add Name:=separ & 2, RefersToR1C1:=f
 
Next x
End Sub

voilà j'ai corrigé, suis-je bete :oops:

24/04/2009, 18h05
azerty1956

C'est le même code casefayere, tjrs le même bug ? :cry:

Non, cette fois j'ai bien regardé, ce n'est pas le meme code et je l'ai testé, ça fonctionnait impeccable, preuve :
une correction
Code:

1 2 3 separ = Replace(Range("a" & deb(x)).Value, "-", "_") f = "" & "=Sheet1!R" & deb(x) & "C1:R" & fin(x) & "C3" & "" ActiveWorkbook.Names.Add Name:=separ, RefersToR1C1:=f
ancien code
Code:

1 2 3 separ = Replace(Range("a" & deb(x)).Value, "-", "_") f = "" & "=Sheet1!R" & deb(x) & "C1:R" & fin(x) & "C3" & "" ActiveWorkbook.Names.Add Name:=Range("a" & deb(x)).Value, RefersToR1C1:=f
si tu veux, je t'envoie le fichier avec les corrections

24/04/2009, 18h20
azerty1956

Envoie moi le fichier stp.
sinon sur mon vrai tableau les lignes commencent à partir de la 3ème ligne

merci
24/04/2009, 18h27
casefayere

ok, vois le fichier joint, adaptes pour la ligne 3 ou sinon je le fais et t'envoies

Voir 40 message(s) de cette discussion en une page