Discussion :

[azerty1956]

Bonsoir casefayere,

Justement dans l'exemple, j'ai "défusionné" les cellules de la ligne 1....je pensais que c'était plus simple de coder dans le cas de cellules non fusionnées.

Je ne sais pas si on peut créer des blocs pour chaque catégorie (Allant jusqu'au bout de la cellule fusionnée comme tu viens de le préciser)

A ce moment la, il faudra changer le code précédent pour ne pas prendre 50 colonnes à chaque coup mais plutôt le nombre de colonnes de chaque catégorie (= nombre de colonnes inséré dans les blocs intégrant la ligne 1&2) . Cette méthode sera de loin la plus adapté pour atteindre mes objectifs...

Je pensais que ça n'était pas faisable...
est ce que c'est le cas?

Je te remercie pour tes interventions bien réfléchies casefayere...

Bonne nuit

@+

[casefayere]

Bonjour Azerty, re le forum,

Ce que tu demande doit être possible mais je crois qu'il faut tout repensé,

Il fait beau dehors, j'ai du travail dans le jardin, il faut que j'en profite mais je vais réfléchir à ta nouvelle idée....patience

Bon Weed-end

[casefayere]

Bonsoir Azerty, le forum,
pour tes blocs "entetes"
Bon, je défusionne tes cellules en ligne 1 (il faut les laisser défusionnées)

j'ai ce code pour creer les blocs

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
Sub entetes()
Dim dernierecolonne As Integer, x As Integer, w As Integer, nbblocs As Integer
dernierecolonne = ActiveSheet.Range("IV2").End(xlToLeft).Column
nbblocs = Int((dernierecolonne - 4) / 50)
w = 3
For x = 1 To nbblocs
x = (50 * x) + 5
If dernierecolonne >= x = (50 * x) + 55 Then
ActiveWorkbook.Names.Add Name:="Sheet1Head" & w, RefersToR1C1:="=sheet1!R1C" & x & ":R2C" & x + 49 & ""
w = w + 1
Else
ActiveWorkbook.Names.Add Name:="Sheet1Head" & w, RefersToR1C1:="=sheet1!R1C" & x & ":R2C" & dernierecolonne & ""
Exit For
End If
Next x
End Sub

ce code, on l'appelle à l'interieur de l'autre procédure pour les autres blocs, après :

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
.....
'alimente les deux tableaux debut et fin des noms à définir
z = 1
ReDim deb(2)
ReDim fin(2)
deb(1) = 3
'/////////////////////////////////////////////////////////////////////////////////
'Pour 1er entete
ActiveWorkbook.Names.Add Name:="Sheet1Head1", RefersToR1C1:="=sheet1!R1C1:R2C3"
'pour 2eme entete
ActiveWorkbook.Names.Add Name:="Sheet1Head2", RefersToR1C1:="=sheet1!R1C5:R2C54"
'pour suivants
entetes 'il est ici
'//////////////////////////////////////////////////////////////////////////////////
 
For x = 3 To DerniereLigne
If Range("a" & x).Interior.ColorIndex = 48 Then ' code couleur
......

si tu as compris ma démarche, on pourras continuer

j'espère que tu as compris que j'ai fait une macro à part pour les entetes, pour la clarté de ta compréhension mais on pourra l'intégrer dans la macro "blocs", ça c'est toi qui décideras

Bonne journée

[casefayere]

Je continue à travailler et fait le ménage,

le fichier que tu m'as laissé et que j'ai pris comme base est joint.
attention, il n'y a plus de cellules fusionnées sinon ça ne fonctionnera pas pour les entetes

toujours en considérant tes blocs de 20 colonnes, 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
Option Explicit
Option Base 1 'n'oublies pas ça
Sub Bloc()
Dim x As Integer, w As Integer, DerniereLigne As Integer, dernierecolonne As Integer
Dim z As Integer, deb() As Integer, fin() As Integer, y As Integer
Dim separ As String, f As String
'***************************************************************
DerniereLigne = ActiveSheet.Range("D" & Rows.Count).End(xlUp).Row
dernierecolonne = ActiveSheet.Range("IV2").End(xlToLeft).Column
'/////////////////////////////////////////////////////////////////////////////////
'Pour 1er entete
ActiveWorkbook.Names.Add Name:="Sheet1Head1", RefersToR1C1:="=sheet1!R1C1:R2C3"
'pour 2eme entete
ActiveWorkbook.Names.Add Name:="Sheet1Head2", RefersToR1C1:="=sheet1!R1C5:R2C24"
'pour suivants
w = 3
For x = 25 To dernierecolonne + 20
If dernierecolonne < x + 19 Then
ActiveWorkbook.Names.Add Name:="Sheet1Head" & w, RefersToR1C1:="=sheet1!R1C" & x & ":R2C" & dernierecolonne & ""
Exit For
Else
ActiveWorkbook.Names.Add Name:="Sheet1Head" & w, RefersToR1C1:="=sheet1!R1C" & x & ":R2C" & x + 19 & ""
End If
w = w + 1
x = (20 * (w - 2)) + 4
Next x
'//////////////////////////////////////////////////////////////////////////////////
'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 auras 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 auras 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) & "C24" & ""
ActiveWorkbook.Names.Add Name:="sheet" & "2" & separ, RefersToR1C1:=f
Next x
'***************************************************************************
'pour le reste
y = 25
For x = 1 To UBound(deb, 1)
separ = Application.WorksheetFunction.Substitute(Range("a" & deb(x)).Value, "-", "_")
f = "" & "=sheet1!R" & deb(x) & "C" & y & ":R" & fin(x) & "C" & y + 19 & ""
ActiveWorkbook.Names.Add Name:="sheet" & x + 2 & separ, RefersToR1C1:=f
y = y + 20
If y >= dernierecolonne - 19 Then
Exit For
End If
Next x
w = x + 3
'*************************************************************************
'pour la derniere colonne
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" & dernierecolonne & ""
ActiveWorkbook.Names.Add Name:="sheet" & w & separ, RefersToR1C1:=f
Next x
 
End Sub

[azerty1956]

Bonsoir casefayere,

Si je ne t'ai pas répondu, c'est que j'attendais d'essayer ce code sur mon vrai grand tableau pour voir si ça marche, pour être sur de ne pas te poser des questions "bêtes"....J'ai essayé sur le tableau exemple mais ça ne me donne pas tous les blocs dont j'ai besoin....j'attends de l'essayer sur mon vrai tableau (que je n'ai pas sur mon pc personnel) et je te tiens au courant demain matin...

Merci d'avance pour ton aide...
A demain

Bonne soirée

[Fouinette85]

Personnellement pour imprimer le tableau j'aurais simplement "figer les volets"
avec une macro pour que le scroll et l'impression se fasse automatiquement si tu as souvent à réimprimer ton tableau mais ce n'est pas très compliqué.

[Fouinette85]

Figer les volets consiste juste à conserver ta première ligne et/ou ta première colonne. Ce qui te permettrais d'imprimer tes données en gardant tes en tête de lignes et/ou colonne.
Je te join ton fichier avec les volets figer, j'espère que sa gardera cette mise en page quand tu l'ouvrira sinon il te suffit (sur excel 2007) d'aller dans l'onglet affichage > dans la partie fenêtre tu as 3 choix pour figer les volets, dans ton cas je pense que le premier est le plus adapter, tu te positionne en "B2" et tu choisi "figer les volets". Si tu n'as pas excel 2007 je pense que tu dois pouvoir retrouver cette fonctionnalité dans les paramètre d'affichage.

Si cette mise en page te convient il te suffira de créer une macro qui scroll vers le bas d'une vingtaine de ligne jusqu'a ce que toutes tes lignes soit parcourues et idem pour les colonnes.