Impression d'une colonne

[JF PELLEVOIZIN]

Malgré vos réponses je ne réussie pas imprimer une colonne sur plusieurs

[...pat]

Essaies ceci: (de J. Walkenbach)

Attribute VB_Name = "snake_cols"
Public Sub SnakeCols()
'David McRitchie http://members.aol.com/dmcritchie/excel/excel.htm snake
columns
' Current code is in http://members.aol.com/rexx03/excel/snakecol.htm
' Install on Tools menu for testing and production once have INPUTBOX
' testing.xls module(snakey) test with worksheet(snaketest)
' Copier la colonne A en 2 ou 3 colonnes pour imprimer moins de feuilles
'
' Place en plusieurs colonnes pour impression une colonne A qui serait
trop
' longue pour s'imprimer sur une page
'ex: 80 lignes s'imprimeront en 2 colonne sur la meme et unique feuille
'
Dim hcols As Integer, cols As Integer, setts As Integer
Dim chunks As Integer
Dim lastrow As Integer
Dim wsSource As Worksheet
Dim wsNew As Worksheet
Dim sett As Integer, chunk As Integer
Dim orient As String
Dim largeur As Integer
'THIS WILL BE PUT INTO AN INPUTBOX LATER
hrows = 1 'specify number of heading rows
cols = 1 'specify number of cols to copy
setts = 3 'specify number of sets per page
rowspp = 25 'specify number of rows per page

'orientation portrait ou paysage
demande_orientation:
orient = InputBox("Orientation papier Verticale ou Horizontale")

If orient <> "v" And orient <> "V" And orient <> "h" And orient <> "H" Then
_
GoTo demande_orientation

' nombre maxi de colonnes
colmaxi:
cols = InputBox("Entrez le nombre de colonnes à copier")
If cols < 1 Or cols > 5 Then GoTo colmaxi
' mesurer largeur de data et mettre la largeur de colonne un peu plus grande
largeur = Len(ActiveCell)
MsgBox largeur
'Selection.ColumnWidth = 21

' nombre maxi de lignes
rows_pp:
rowspp = InputBox("Nombre de lignes par page")
If rowspp < 1 Or ligne > 52 Then GoTo rows_pp

Set lastcell = Cells.SpecialCells(xlLastCell)
lastrow = lastcell.Row 'lastrow was found for you
maxPages = 1

Set wsSource = ActiveSheet
Set wsNew = Worksheets.Add
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Copy the Heading Area
srow = 1
scol = 1
srow2 = hrows
scol2 = cols
'srow , scol, srow2, scol2, drow, dcol, wsSource, wsNew
Sheets(wsSource.Name).Select
Range(Cells(1, 1), Cells(srow2, scol2)).Select
Application.CutCopyMode = False
Selection.Copy

'Paste heading areas into New Sheet and make boldface
drow = 1 'destination row will be incremented
dcol = 1 'destination column will be incremented
For sett = 1 To setts Step 1
Sheets(wsNew.Name).Select
Range(Cells(drow, dcol), Cells(drow, dcol)).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
dcol = dcol + cols
Next sett
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$" & cols
.PrintTitleColumns = ""
End With
Rows("$1:$" & cols).Select
Selection.Font.Bold = True

'Break into chunks and paste into New Sheet
srow = srow + hrows
scol = 1 'never changes
dcol = 1
drow = drow + hrows

chunks = Int((lastrow - hrows + rowspp - 1) / rowspp)
maxPages = Int((chunks + setts - 1) / setts)

For chunk = 1 To chunks Step 1
If srow > lastrow Then GoTo done
dcol = 1
For sett = 1 To setts Step 1
scol = 1
srow2 = srow + rowspp - 1
col2 = cols

Sheets(wsSource.Name).Select
Range(Cells(srow, scol), Cells(srow2, scol2)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets(wsNew.Name).Select
Range(Cells(drow, dcol), Cells(drow, dcol)).Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

dcol = dcol + cols
srow = srow + rowspp
Rows(srow).Select
ActiveCell.PageBreak = xlManual
' Row(srow).PageBreak = xlManual 'xlcalculationmanual in xl97
Next sett
drow = drow + rowspp
Next chunk
done:
Cells.Select 'Select ALL cells
Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True 'place at end when debugged
Application.DisplayAlerts = True

MsgBox ("La vue avant impression est à présent activée, ajustez les
marges. " _
& "Vous avez plus de " & maxPages & " pages. " _
& "Vous êtes maintenant prêt pour imprimer cette nouvelle feuille, " _
& "et pour la renommer si nécessaire")
' mettre ici la feuille en paysage
Application.ScreenUpdating = False

With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.590551181102362)
.RightMargin = Application.InchesToPoints(0.590551181102362)
.TopMargin = Application.InchesToPoints(0.590551181102362)
.BottomMargin = Application.InchesToPoints(0.748031496062992)
.HeaderMargin = Application.InchesToPoints(0.31496062992126)
.FooterMargin = Application.InchesToPoints(0.433070866141732)
If orient = "v" Or orient = "V" Then
.Orientation = xlPortrait
Else
.Orientation = xlLandscape
End If
ActiveSheet.PrintPreview
End With
End Sub

--
Le Savoir de l'Homme n'est rien sans le partage et la communication
(PMK)

"JF PELLEVOIZIN" <jf.pell...@wanadoo.fr> a écrit dans le message news:
8nu6t5$558$1...@news.x-echo.com...

[Clément Marcotte]

"JF PELLEVOIZIN" <jf.pell...@wanadoo.fr> a écrit dans le message news:
8nu6t5$558$1...@news.x-echo.com...
> Malgré vos réponses je ne réussie pas imprimer une colonne sur plusieurs

Sur plusieurs ????

Si tu parles de répartir 1 colonne sur 6 ou 7, tu pourrais peut-être, sur
une nouvelle feuille, recopier, dans chacune de 6 colonnes, la quantité
nécessaire de données, pour remplir une page. Si cela revient souvent,
essaie d'enregistrer une macro.
--
Clément Marcotte
"Être vraiment patient, c'est être patient quand vous ne pensiez plus qu'il
était possiblement concevable de l'être."
- Léonard de Vinci

[Jacky @*10-1]

Qu'est-ce qui ne va pas avec le publipostage de word ?
A plus
Jacky

JF PELLEVOIZIN a écrit dans le message <8nu6t5$558$1...@news.x-echo.com>...

[Frédéric Sigonneau]

JF PELLEVOIZIN a écrit :

>
> Malgré vos réponses je ne réussie pas imprimer une colonne sur plusieurs

En supposant que la fin de la question soit "plusieurs pages", tu peux
essayer avec cette macro :

Sub testImpr()
nFeuille = InputBox("Feuille à traiter :")
nCell = InputBox("Notez une cellule dans la colonne à découper (ex
A1) :")
nCol = InputBox("Nb de colonnes dans la présentation :")
nLi = InputBox("Nb de lignes par pages après découpage :")
ImprimeEnColonnes nFeuille, Range(nCell), nCol, nLi
'ImprimeEnColonnes "Feuil1", [A1], 4, 30
End Sub

Sub ImprimeEnColonnes(ByVal NomFeuille As String, _
Source As Range, ByVal nbCol As Byte, ByVal nbLi As Byte)
Dim ShSrc As Worksheet, ShTmp As Worksheet

Set ShSrc = ActiveWorkbook.Worksheets(NomFeuille)
Application.ScreenUpdating = False
ActiveWorkbook.Worksheets.Add
Set ShTmp = ActiveWorkbook.Worksheets(Worksheets.Count)
On Error GoTo Fin

derli = Source.End(xlDown).Row
colSrc = Source.Column

ShSrc.Activate
ShSrc.Range(Cells(1, colSrc), Cells(derli, colSrc)).Select
Selection.Copy
ShTmp.Activate
ShTmp.Range("A1").PasteSpecial xlPasteAll

With ActiveSheet
x = 1
For i = 1 To derli
For y = 2 To nbCol + 1
.Range(Cells(i, 1), Cells(i + nbLi - 1, 1)).Select
Selection.Copy
.Cells(x, y).PasteSpecial xlPasteAll
i = i + nbLi
Next y
x = x + nbLi
i = i - 1
Next i
.Columns(1).Delete
.UsedRange.Columns.AutoFit
For i = nbLi To .UsedRange.End(xlDown).Row Step nbLi
.HPageBreaks.Add before:=.Range("A" & i + 1)
Next i
.PrintOut
End With

Application.DisplayAlerts = False
ShTmp.Delete
Application.DisplayAlerts = True

ShSrc.Activate
[A1].Select
Fin:
Application.ScreenUpdating = True
End Sub

FS
--
Frédéric Sigonneau
Gestions de temps : http://perso.wanadoo.fr/frederic.sigonneau
Time managements : http://perso.wanadoo.fr/frederic.sigonneau/index2.htm

[Frédéric Sigonneau]

Sabatier a écrit :
>
> au sujet de cette macro, je voudrais dire deux choses :
> 1) elle peut être très dangereuse pour celui qui voudrait imprimer un
> classeur ne contenant qu'un seule feuille car il aurait la très
> désagréable surprise de ne plus rien avoir dans son classeur à la fin de
> la manip' (c'est ce qui m'est arrivé et Dieu merci, ça ne représentait
> pas trois mois de travail)

Honte sur moi :-(((
Aucune excuse. J'ai tellement pris l'habitude d'insérer les nouvelles
feuilles dans un classeur à droite des autres, que j'ai oublié qu'Excel,
lui, les insère à gauche..

> 2) il me semble préférable de remplacer le PrintOut par PrintPreview car
> si on n'est pas satisfait de l'effet produit, on peut remettre le
> travail sur l'ouvrage

Pour éviter des allers-retours dans le code, j'ai ajouté un paramètre
supplémentaire (Aperçu). A True on a l'aperçu avant impression, à False
on imprime.

> j'espère que frédéric ne m'en voudra pas de ces remarques

Non, bien sûr. Je vais juste essayer d'attirer le moins souvent possible
sur moi les foudres du mpfe testologue.

Avec correction :

Sub testImpr()
On Error GoTo fin

nFeuille = InputBox("Feuille à traiter :")

nCell = InputBox _
("Notez une cellule de la colonne à découper (ex A1) :")

nCol = InputBox("Nb de colonnes dans la présentation :")
nLi = InputBox("Nb de lignes par pages après découpage :")

ImprimeEnColonnes nFeuille, Range(nCell), nCol, nLi, True
fin:
Exit Sub
End Sub

Sub ImprimeEnColonnes(ByVal NomFeuille As String, _

Source As Range, ByVal nbCol As Byte, ByVal nbLi As Byte, _
Aperçu As Boolean)

Dim ShSrc As Worksheet, ShTmp As Worksheet

Set ShSrc = ActiveWorkbook.Worksheets(NomFeuille)
Application.ScreenUpdating = False
ActiveWorkbook.Worksheets.Add

Set ShTmp = ActiveWorkbook.ActiveSheet '<-- correction ici

derli = Source.End(xlDown).Row
colSrc = Source.Column

ShSrc.Activate
ShSrc.Range(Cells(1, colSrc), Cells(derli, colSrc)).Select
Selection.Copy
ShTmp.Activate
ShTmp.Range("A1").PasteSpecial xlPasteAll

With ActiveSheet
x = 1
For i = 1 To derli
For y = 2 To nbCol + 1
.Range(Cells(i, 1), Cells(i + nbLi - 1, 1)).Select
Selection.Copy
.Cells(x, y).PasteSpecial xlPasteAll
i = i + nbLi
Next y
x = x + nbLi
i = i - 1
Next i
.Columns(1).Delete
.UsedRange.Columns.AutoFit
For i = nbLi To .UsedRange.End(xlDown).Row Step nbLi
.HPageBreaks.Add before:=.Range("A" & i + 1)
Next i

If Aperçu Then
.PrintPreview
Else
.PrintOut
End If

End With

Application.DisplayAlerts = False
ShTmp.Delete
Application.DisplayAlerts = True

ShSrc.Activate
[A1].Select
End Sub

[Sabatier]

au sujet de cette macro, je voudrais dire deux choses :
1) elle peut être très dangereuse pour celui qui voudrait imprimer un
classeur ne contenant qu'un seule feuille car il aurait la très
désagréable surprise de ne plus rien avoir dans son classeur à la fin de
la manip' (c'est ce qui m'est arrivé et Dieu merci, ça ne représentait
pas trois mois de travail)

2) il me semble préférable de remplacer le PrintOut par PrintPreview car
si on n'est pas satisfait de l'effet produit, on peut remettre le
travail sur l'ouvrage

j'espère que frédéric ne m'en voudra pas de ces remarques ; je crois
savoir qu'il connaît déjà ce côté emm.... que j'ai hérité de mon ancêtre
vercingétorix, démolisseur tout autant de macros que d'oppida
cordialement
jps (du gouleyant beaujolais)

Frédéric Sigonneau wrote:
>
> JF PELLEVOIZIN a écrit :
> >
> > Malgré vos réponses je ne réussie pas imprimer une colonne sur plusieurs
>
> En supposant que la fin de la question soit "plusieurs pages", tu peux
> essayer avec cette macro :
>
> Sub testImpr()

> nFeuille = InputBox("Feuille à traiter :")

> nCell = InputBox("Notez une cellule dans la colonne à découper (ex

> A1) :")
> nCol = InputBox("Nb de colonnes dans la présentation :")
> nLi = InputBox("Nb de lignes par pages après découpage :")

> ImprimeEnColonnes nFeuille, Range(nCell), nCol, nLi
> 'ImprimeEnColonnes "Feuil1", [A1], 4, 30

> End Sub
>
> Sub ImprimeEnColonnes(ByVal NomFeuille As String, _

> Source As Range, ByVal nbCol As Byte, ByVal nbLi As Byte)

> Dim ShSrc As Worksheet, ShTmp As Worksheet
>
> Set ShSrc = ActiveWorkbook.Worksheets(NomFeuille)
> Application.ScreenUpdating = False
> ActiveWorkbook.Worksheets.Add

> Set ShTmp = ActiveWorkbook.Worksheets(Worksheets.Count)
> On Error GoTo Fin
>

> derli = Source.End(xlDown).Row
> colSrc = Source.Column
>
> ShSrc.Activate
> ShSrc.Range(Cells(1, colSrc), Cells(derli, colSrc)).Select
> Selection.Copy
> ShTmp.Activate
> ShTmp.Range("A1").PasteSpecial xlPasteAll
>
> With ActiveSheet
> x = 1
> For i = 1 To derli
> For y = 2 To nbCol + 1
> .Range(Cells(i, 1), Cells(i + nbLi - 1, 1)).Select
> Selection.Copy
> .Cells(x, y).PasteSpecial xlPasteAll
> i = i + nbLi
> Next y
> x = x + nbLi
> i = i - 1
> Next i
> .Columns(1).Delete
> .UsedRange.Columns.AutoFit
> For i = nbLi To .UsedRange.End(xlDown).Row Step nbLi
> .HPageBreaks.Add before:=.Range("A" & i + 1)
> Next i

> .PrintOut

> End With
>
> Application.DisplayAlerts = False
> ShTmp.Delete
> Application.DisplayAlerts = True
>
> ShSrc.Activate
> [A1].Select

[Sabatier]

suite à mon post d'il y a un petit moment, je pense que ce serait pas
mal de rédiger la première Sub de cette macro comme suit :

Sub testImpr()
alerte = MsgBox("avez-vous bien une feuille vide dans ce classeur?",
vbYesNo, "ACHTUNG MINEN GEFAHR")
If alerte = vbNo Then Exit Sub

nFeuille = InputBox("Feuille à traiter :")
nCell = InputBox("Notez une cellule dans la colonne à découper

(exA1) :")

nCol = InputBox("Nb de colonnes dans la présentation :")
nLi = InputBox("Nb de lignes par pages après découpage :")
ImprimeEnColonnes nFeuille, Range(nCell), nCol, nLi
'ImprimeEnColonnes "Feuil1", [A1], 4, 30
End Sub

on se sentirait mieux dans ses baskets avant de faire le grand saut...de
page
à +
jps

[Sabatier]

Frédéric Sigonneau wrote:

merci frédéric pour cette ENORME effort d'amélioration, même si je ne
comprends pas cette histoire de PrintPreview sur True ou sur False
si, en ma qualité de mpfe testologue, je teste la macro telle quel, je
débouche sur l'aperçu dans tous les cas et dois faire imprimer dans la
fenêtre de l'aperçu pour envoyer sur l'imprimante
est-ce bien cela?
jps
PS j'ai tellement aimè mon MsgBox que vous ne m'en voudrez pas de
l'avoir conservé malgré le "Add" d'une Sheet

>
> Pour éviter des allers-retours dans le code, j'ai ajouté un paramètre
> supplémentaire (Aperçu). A True on a l'aperçu avant impression, à False
> on imprime.
>

> Avec correction :