Insérer un tableau Excel en paysage dans une page Word portrait?

--
JLuc

Bonjour à toi aussi,

Olivier Lebel a présenté l'énoncé suivant :

Dans un document Word, avec de nombreux liens vers des tableaux Excel, je
souhaite insérer des tableaux en format paysage, en conservant mes en-tête et
pieds de pages en format portrait. La seule méthode que j'ai trouvée consiste
à faire une image du tableau Excel, mais sa rotation est désastreuse pour el
graphisme des caractères. Si accesoirement je pouvais conserver le lien
dynamique, ce serait mieux, mais ce n'est pas absolument indispensable.
Comment faire?

Il y a plusieurs solutions...
Mais il faut attendre le robot de service...

Circé

Merci et bonjour. Je ne suis pas sûr de comprendre ce qu'est le robot de
service. Joke ou technique?

Bonjour à toi aussi,

Olivier Lebel a présenté l'énoncé suivant :

Dans un document Word, avec de nombreux liens vers des tableaux Excel, je
souhaite insérer des tableaux en format paysage, en conservant mes en-tête et
pieds de pages en format portrait. La seule méthode que j'ai trouvée consiste
à faire une image du tableau Excel, mais sa rotation est désastreuse pour el
graphisme des caractères. Si accesoirement je pouvais conserver le lien
dynamique, ce serait mieux, mais ce n'est pas absolument indispensable.
Comment faire?

Il y a plusieurs solutions...
Mais il faut attendre le robot de service...

Circé

J'ai supprimer mon message, est ce bon ?

--
JLuc

Mmmm...Je ne ferai pas de commentaire sur le robot de service.
Concernant la rotation de ton tableau Excel, j'ai retrouvé ça, qui
fonctionnait parfaitement (je ne m'en suis plus servi depuis très longtemps.
Essaie.
Option Explicit

Option Base 1

Dim TabFormules()

Public TotLig As Byte, TotCol As Byte

Dim l As Byte, C As Byte

Sub RotationSurSelection()

Dim L2 As Long, L1 As Long

Dim C1 As Integer, C2 As Integer, N As Byte

Dim F1, Calc As Boolean, Réponse As Long

Calc = Application.Calculation

Application.Calculation = xlCalculationManual

Application.ScreenUpdating = False

Set F1 = ActiveSheet

TotLig = Selection.Rows.Count

TotCol = Selection.Columns.Count

If TotLig = 1 And TotCol = 1 Then

If ActiveCell.CurrentRegion.Cells.Count = 1 Then

MsgBox "Veuillez sélectionner le tableau à transposer !"

Exit Sub

Else

Réponse = MsgBox("Sélection non valide." & Chr(13) & _

"Voulez-vous utiliser la zone en courscomme sélection ?", _

vbYesNo + vbQuestion, "Transposition de tableau")

If Réponse = vbNo Then Exit Sub

ActiveCell.CurrentRegion.Select

TotLig = Selection.Rows.Count

TotCol = Selection.Columns.Count

End If

End If

Call ConversionFormules(TotLig, TotCol)

Sheets.Add.Move After:=Sheets(Worksheets.Count)

ActiveSheet.Name = "Transpose"

F1.Select

Selection.Copy

Sheets("Transpose").Activate

ActiveSheet.Paste Destination:¬tiveSheet.Cells(TotCol + 1, 1)

C1 = 1

For L2 = TotCol + 1 To TotCol + TotLig

C2 = 1

L1 = TotCol

For C2 = 1 To TotCol

Cells(L2, C2).Cut (Cells(L1, C1))

L1 = L1 - 1

Next C2

C1 = C1 + 1

Next L2

With Range("A1").CurrentRegion

.HorizontalAlignment = xlGeneral

.VerticalAlignment = xlBottom

.WrapText = False

.Orientation = 90

.ShrinkToFit = False

.MergeCells = False

.EntireColumn.AutoFit

End With

For C = 1 To Range("A1").CurrentRegion.Columns.Count

For l = 1 To Range("A1").CurrentRegion.Rows.Count

If Range(TabFormules(l, C, 2)).HasFormula = True And (TabFormules(l, C, 4))
Then

Call RemplFormule(l, C)

End If

Next l

Next C

If Calc = True Then Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

End Sub '_________________________________________________



Sub AnnuleRotationSurSelection()

Dim L2 As Long, L1 As Long, N As Byte

Dim C1 As Integer, C2 As Integer, Réponse As Long

Dim F1, Calc As Boolean

Calc = Application.Calculation

Application.Calculation = xlCalculationManual

Application.ScreenUpdating = False

Set F1 = ActiveSheet

TotLig = Selection.Rows.Count

TotCol = Selection.Columns.Count

If TotLig = 1 And TotCol = 1 Then

If ActiveCell.CurrentRegion.Cells.Count = 1 Then

MsgBox "Veuillez sélectionner le tableau à transposer !"

Exit Sub

Else

Réponse = MsgBox("Sélection non valide." & Chr(13) & _

"Voulez-vous utiliser la zone en cours comme sélection ?", _

vbYesNo + vbQuestion, "Annulation de transposition de tableau")

If Réponse = vbNo Then Exit Sub

ActiveCell.CurrentRegion.Select

TotLig = Selection.Rows.Count

TotCol = Selection.Columns.Count

End If

End If

Call AnnConversionFormules(TotLig, TotCol)

Sheets.Add.Move After:=Sheets(Worksheets.Count)

ActiveSheet.Name = "AnnuleTranspose"

F1.Select

Selection.Copy

Sheets("AnnuleTranspose").Activate

ActiveSheet.Paste Destination:¬tiveSheet.Cells(TotCol + 1, 1)

C1 = TotLig

For L2 = TotCol + 1 To TotCol + TotLig

C2 = 1

L1 = 1

For C2 = 1 To TotCol

Cells(L2, C2).Cut (Cells(L1, C1))

L1 = L1 + 1

Next C2

C1 = C1 - 1

Next L2

With Range("A1").CurrentRegion

.HorizontalAlignment = xlGeneral

.VerticalAlignment = xlBottom

.WrapText = False

.Orientation = 0

.ShrinkToFit = False

.MergeCells = False

End With

For C = 1 To Range("A1").CurrentRegion.Columns.Count

For l = 1 To Range("A1").CurrentRegion.Rows.Count

If Range(TabFormules(l, C, 2)).HasFormula = True And (TabFormules(l, C, 4))
Then

Call RemplFormule(l, C)

End If

Next l

Next C

If Calc = True Then Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

End Sub ' __________________________________________________



Sub ConversionFormules(TotLig As Byte, TotCol As Byte)

ReDim TabFormules(TotCol, TotLig, 4)

For C = 1 To TotCol

For l = 1 To TotLig

TabFormules(C, l, 1) = Cells(l, C).Address(0, 0)

TabFormules(C, l, 2) = Cells(TotCol + 1 - C, l).Address(0, 0)

If Cells(l, C).HasFormula = True Then TabFormules(C, l, 3) = Cells(l,
C).FormulaLocal

Next l

Next C

For C = 1 To TotCol

For l = 1 To TotLig

If Not IsEmpty(TabFormules(C, l, 3)) Then

Call Conversion(l, C)

End If

Next l

Next C

End Sub '_________________________________________________



Private Sub Conversion(l As Byte, C As Byte)

Dim U As Integer, V As Integer, W As Integer, X As Integer, Y As Integer, Z
As Integer

Dim PremCell1 As String, PremCell2 As String

Dim DernCell1 As String, DernCell2 As String

Dim wPlage As String, D1 As Byte, D2 As Byte, D3 As Byte, D4 As Byte, Nf As
Byte

Dim TestPremcell As Range, TestDernCell As Range

V = 1

Do

D1 = 0: D2 = 0: D3 = 0: D4 = 0

On Error Resume Next

Y = WorksheetFunction.Find(":", TabFormules(C, l, 3), V)

If Err.Number = 1004 Then

Err.Clear

Exit Sub

End If

On Error GoTo 0

For X = Y To 1 Step -1

If Right(Left(TabFormules(C, l, 3), X), 1) = "(" Or
Right(Left(TabFormules(C, l, 3), X), 1) = ";" Then

Exit For

End If

Next

For Z = Y To Len(TabFormules(C, l, 3)) Step 1

If Right(Left(TabFormules(C, l, 3), Z), 1) = ")" Or
Right(Left(TabFormules(C, l, 3), Z), 1) = ";" Then

Exit For

End If

Next

wPlage = Left(Right(TabFormules(C, l, 3), Len(TabFormules(C, l, 3)) - (X)),
Z - X - 1)

W = WorksheetFunction.Find(":", wPlage, 1)

PremCell1 = Left(wPlage, W - 1)

DernCell1 = Right(wPlage, Len(wPlage) - W)

On Error Resume Next

D1 = WorksheetFunction.Find("$", Left(PremCell1, 1))

If Err.Number = 1004 Then D1 = 0: Err.Number = 0

D2 = WorksheetFunction.Find("$", PremCell1, 2)

If Err.Number = 1004 Then D2 = 0: Err.Number = 0

PremCell2 = Recherche(Range(PremCell1).Address(0, 0), D1, D2)

D3 = WorksheetFunction.Find("$", Left(DernCell1, 1))

If Err.Number = 1004 Then D1 = 0: Err.Number = 0

D4 = WorksheetFunction.Find("$", DernCell1, 2)

If Err.Number = 1004 Then D2 = 0: Err.Number = 0

On Error GoTo 0

DernCell2 = Recherche(Range(DernCell1).Address(0, 0), D3, D4)

Dim Test

Test = Len(Range(PremCell1).Offset(TotCol, 0).Address(D2, D1)) +
Len(Range(DernCell1).Offset(TotCol, 0).Address(D2, D1)) + 1

If Not TabFormules(C, l, 4) Then TabFormules(C, l, 4) = True

If (7 + Nf + 3) > UBound(TabFormules, 3) Then ReDim Preserve
TabFormules(TotCol, TotLig, UBound(TabFormules, 3) + 3)

If Len(PremCell2 & ":" & DernCell2) > 4 Then

TabFormules(C, l, 4 + Nf + 1) = PremCell2 & ":" & DernCell2

TabFormules(C, l, 4 + Nf + 2) = X + 1 + U

TabFormules(C, l, 4 + Nf + 3) = Len(Range(PremCell1).Offset(TotCol,
0).Address(D2, D1)) + Len(Range(DernCell1).Offset(TotCol, 0).Address(D4,
D3)) + 1

U = U + Len(PremCell2 & ":" & DernCell2) - Len(PremCell1 & ":" & DernCell1)

Nf = Nf + 3

End If

V = Z + 1

Loop

End Sub '_________________________________________________

Private Function Recherche(wcell, D1, D2)

Dim M As Integer, N As Integer

For N = 1 To UBound(TabFormules, 1)

For M = 1 To UBound(TabFormules, 2)

If TabFormules(N, M, 1) = wcell Then

Recherche = Range(TabFormules(N, M, 2)).Address(D2, D1)

Exit Function

End If

Next M

Next N

End Function '_________________________________________________

Private Sub RemplFormule(l, C)

Dim U As Integer, V As Integer, W As Integer, X As Integer, Y As Integer

Dim Z As Integer, N As Byte, wFormule As String

V = 1

wFormule = Range(TabFormules(l, C, 2)).FormulaLocal

For N = 5 To UBound(TabFormules, 3) Step 3

If Not IsEmpty(TabFormules(l, C, N)) Then

On Error Resume Next

Y = WorksheetFunction.Find(":", wFormule, V)

If Err.Number = 1004 Then

Stop

Err.Clear

Exit Sub

End If

On Error GoTo 0

For X = Y To 1 Step -1

If Right(Left(wFormule, X), 1) = "(" Or Right(Left(wFormule, X), 1) = ";"
Then

Exit For

End If

Next

For Z = Y To Len(wFormule) Step 1

If Right(Left(wFormule, Z), 1) = ")" Or Right(Left(wFormule, Z), 1) = ";"
Then

Exit For

End If

Next

wFormule = WorksheetFunction.Replace(wFormule, X + 1, Z - X - 1,
TabFormules(l, C, N))

End If

V = Z + 1

Next N

Range(TabFormules(l, C, 2)).FormulaLocal = wFormule

End Sub



Sub AnnConversionFormules(Totig As Byte, Totol As Byte)

Dim C As Byte, l As Byte

ReDim TabFormules(TotCol, TotLig, 4)

For C = 1 To TotCol

For l = 1 To TotLig

TabFormules(C, l, 1) = Cells(l, C).Address(0, 0)

TabFormules(C, l, 2) = Cells(C, TotLig + 1 - l).Address(0, 0)

If Cells(l, C).HasFormula = True Then TabFormules(C, l, 3) = Cells(l,
C).FormulaLocal

Next l

Next C

For C = 1 To TotCol

For l = 1 To TotLig

If Not IsEmpty(TabFormules(C, l, 3)) Then

Call Conversion(l, C)

End If

Next l

Next C

End Sub '_________________________________________________

"Olivier Lebel" <OlivierLebel@discussions.microsoft.com> a écrit dans le
message de news: 2DC4D583-DBEF-4FF5-834F-385BF0674C78@microsoft.com...

Merci et bonjour. Je ne suis pas sûr de comprendre ce qu'est le robot de
service. Joke ou technique?

Bonjour à toi aussi,

Olivier Lebel a présenté l'énoncé suivant :

Dans un document Word, avec de nombreux liens vers des tableaux Excel,
je
souhaite insérer des tableaux en format paysage, en conservant mes
en-tête et
pieds de pages en format portrait. La seule méthode que j'ai trouvée
consiste
à faire une image du tableau Excel, mais sa rotation est désastreuse
pour el
graphisme des caractères. Si accesoirement je pouvais conserver le lien
dynamique, ce serait mieux, mais ce n'est pas absolument indispensable.
Comment faire?

Il y a plusieurs solutions...
Mais il faut attendre le robot de service...

Circé

Bonjoir(c) JLuc

J'ai supprimer mon message, est ce bon ?

C'est une bonne idée, mais sur les NG de MS les suppression ne sont pas
prise en compte... :-(

Pas grave JLuc, ne te prend pas la tête pour si peu, je pondérerais, et
puis finalement on peut aussi mettre des tag en négatif pour faire un
comptage correct... enfin plus juste je veux dire ;-)

--
JièL / Jean-Louis GOUBERT
http://forums.offices.free.fr/
Là bas mieux qu'en face

Bonjour AB,

Je ne suis pas sur d ecomprendre tout ce que tu écris ni ce qu'il faut en
faire, mais ce que je constate c'est que je n'ai sans odut epas été très
clair dans ma question.
Bon, j'ai un tableau Excel. Je sais bien sûr l'imprimer en paysage ou en
portrait. Je ne cherche pas vraiment à le transposer (rendre les colonnes en
lignes et vice versa). En fait, j'ai sans doute compliqué la chose en parlant
d'Excel. Fondamentalement, j'ai un gros fichier de 100 pages en Word, avec
des en-têtes et des pieds de pages horizontaux (en portrait) à chaque page.
Mais j'ai un tableau qui est trop long pour tenir dans la petite dimension de
la page, et que je souhaite mettre dans la grande dimension (en fait , c'est
plutôt une vingtaine de tableaux Excel, en lien dynamique avec les comptes de
l'association). Si je fais une section avec un format paysage, mes en-tête et
pieds de page apparaissent dans la grande dimension, ce qui fait qu'on ne
voit plus les numéros de page lorsque les pages sont agrafées. J'ai pensé à
faire une image du tableau Excel, et à la faire tourner dans Word, mais le
résultat est pitoyable, les caractères sont à peine lisibles. En passant par
Acrobat, et en la faisant tourner dans Acrobat, en zoomant suffisament (i.e.
plus large que l'écran) et en utilisant l'outil de capture instantané, on
arrive à faire une iamge correcte. Néanmoins, cela présente deux
inconvénients: d'une part c'est relativement fastidieux, mais soit, en
revanche, je perds mes liens dynamiques, ce qui est plus genant si entre
temps le comptable a changé des choses.
Aurais-tu une meilleure piste?

Mmmm...Je ne ferai pas de commentaire sur le robot de service.
Concernant la rotation de ton tableau Excel, j'ai retrouvé ça, qui
fonctionnait parfaitement (je ne m'en suis plus servi depuis très longtemps.
Essaie.
Option Explicit

Option Base 1

Dim TabFormules()

Public TotLig As Byte, TotCol As Byte

Dim l As Byte, C As Byte

Sub RotationSurSelection()

Dim L2 As Long, L1 As Long

Dim C1 As Integer, C2 As Integer, N As Byte

Dim F1, Calc As Boolean, Réponse As Long

Calc = Application.Calculation

Application.Calculation = xlCalculationManual

Application.ScreenUpdating = False

Set F1 = ActiveSheet

TotLig = Selection.Rows.Count

TotCol = Selection.Columns.Count

If TotLig = 1 And TotCol = 1 Then

If ActiveCell.CurrentRegion.Cells.Count = 1 Then

MsgBox "Veuillez sélectionner le tableau à transposer !"

Exit Sub

Else

Réponse = MsgBox("Sélection non valide." & Chr(13) & _

"Voulez-vous utiliser la zone en courscomme sélection ?", _

vbYesNo + vbQuestion, "Transposition de tableau")

If Réponse = vbNo Then Exit Sub

ActiveCell.CurrentRegion.Select

TotLig = Selection.Rows.Count

TotCol = Selection.Columns.Count

End If

End If

Call ConversionFormules(TotLig, TotCol)

Sheets.Add.Move After:=Sheets(Worksheets.Count)

ActiveSheet.Name = "Transpose"

F1.Select

Selection.Copy

Sheets("Transpose").Activate

ActiveSheet.Paste Destination:¬tiveSheet.Cells(TotCol + 1, 1)

C1 = 1

For L2 = TotCol + 1 To TotCol + TotLig

C2 = 1

L1 = TotCol

For C2 = 1 To TotCol

Cells(L2, C2).Cut (Cells(L1, C1))

L1 = L1 - 1

Next C2

C1 = C1 + 1

Next L2

With Range("A1").CurrentRegion

..HorizontalAlignment = xlGeneral

..VerticalAlignment = xlBottom

..WrapText = False

..Orientation = 90

..ShrinkToFit = False

..MergeCells = False

..EntireColumn.AutoFit

End With

For C = 1 To Range("A1").CurrentRegion.Columns.Count

For l = 1 To Range("A1").CurrentRegion.Rows.Count

If Range(TabFormules(l, C, 2)).HasFormula = True And (TabFormules(l, C, 4))
Then

Call RemplFormule(l, C)

End If

Next l

Next C

If Calc = True Then Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

End Sub '_________________________________________________



Sub AnnuleRotationSurSelection()

Dim L2 As Long, L1 As Long, N As Byte

Dim C1 As Integer, C2 As Integer, Réponse As Long

Dim F1, Calc As Boolean

Calc = Application.Calculation

Application.Calculation = xlCalculationManual

Application.ScreenUpdating = False

Set F1 = ActiveSheet

TotLig = Selection.Rows.Count

TotCol = Selection.Columns.Count

If TotLig = 1 And TotCol = 1 Then

If ActiveCell.CurrentRegion.Cells.Count = 1 Then

MsgBox "Veuillez sélectionner le tableau à transposer !"

Exit Sub

Else

Réponse = MsgBox("Sélection non valide." & Chr(13) & _

"Voulez-vous utiliser la zone en cours comme sélection ?", _

vbYesNo + vbQuestion, "Annulation de transposition de tableau")

If Réponse = vbNo Then Exit Sub

ActiveCell.CurrentRegion.Select

TotLig = Selection.Rows.Count

TotCol = Selection.Columns.Count

End If

End If

Call AnnConversionFormules(TotLig, TotCol)

Sheets.Add.Move After:=Sheets(Worksheets.Count)

ActiveSheet.Name = "AnnuleTranspose"

F1.Select

Selection.Copy

Sheets("AnnuleTranspose").Activate

ActiveSheet.Paste Destination:¬tiveSheet.Cells(TotCol + 1, 1)

C1 = TotLig

For L2 = TotCol + 1 To TotCol + TotLig

C2 = 1

L1 = 1

For C2 = 1 To TotCol

Cells(L2, C2).Cut (Cells(L1, C1))

L1 = L1 + 1

Next C2

C1 = C1 - 1

Next L2

With Range("A1").CurrentRegion

..HorizontalAlignment = xlGeneral

..VerticalAlignment = xlBottom

..WrapText = False

..Orientation = 0

..ShrinkToFit = False

..MergeCells = False

End With

For C = 1 To Range("A1").CurrentRegion.Columns.Count

For l = 1 To Range("A1").CurrentRegion.Rows.Count

If Range(TabFormules(l, C, 2)).HasFormula = True And (TabFormules(l, C, 4))
Then

Call RemplFormule(l, C)

End If

Next l

Next C

If Calc = True Then Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

End Sub ' __________________________________________________



Sub ConversionFormules(TotLig As Byte, TotCol As Byte)

ReDim TabFormules(TotCol, TotLig, 4)

For C = 1 To TotCol

For l = 1 To TotLig

TabFormules(C, l, 1) = Cells(l, C).Address(0, 0)

TabFormules(C, l, 2) = Cells(TotCol + 1 - C, l).Address(0, 0)

If Cells(l, C).HasFormula = True Then TabFormules(C, l, 3) = Cells(l,
C).FormulaLocal

Next l

Next C

For C = 1 To TotCol

For l = 1 To TotLig

If Not IsEmpty(TabFormules(C, l, 3)) Then

Call Conversion(l, C)

End If

Next l

Next C

End Sub '_________________________________________________



Private Sub Conversion(l As Byte, C As Byte)

Dim U As Integer, V As Integer, W As Integer, X As Integer, Y As Integer, Z
As Integer

Bonjoir(c) Olivier Lebel

Si j'ai (bien) compris, y'a une solution là :
http://faqword.free.fr/articles.php?lng=fr&pg3
ça le fait ?

--
JièL / Jean-Louis GOUBERT
http://forums.offices.free.fr/
là bas mieux qu'en face ;-)

Le 25/08/2006 13:37 vous avez écrit ceci :

Bonjour AB,

Je ne suis pas sur d ecomprendre tout ce que tu écris ni ce qu'il faut en
faire, mais ce que je constate c'est que je n'ai sans odut epas été très
clair dans ma question.
Bon, j'ai un tableau Excel. Je sais bien sûr l'imprimer en paysage ou en
portrait. Je ne cherche pas vraiment à le transposer (rendre les colonnes en
lignes et vice versa). En fait, j'ai sans doute compliqué la chose en parlant
d'Excel. Fondamentalement, j'ai un gros fichier de 100 pages en Word, avec
des en-têtes et des pieds de pages horizontaux (en portrait) à chaque page.
Mais j'ai un tableau qui est trop long pour tenir dans la petite dimension de
la page, et que je souhaite mettre dans la grande dimension (en fait , c'est
plutôt une vingtaine de tableaux Excel, en lien dynamique avec les comptes de
l'association). Si je fais une section avec un format paysage, mes en-tête et
pieds de page apparaissent dans la grande dimension, ce qui fait qu'on ne
voit plus les numéros de page lorsque les pages sont agrafées. J'ai pensé à
faire une image du tableau Excel, et à la faire tourner dans Word, mais le
résultat est pitoyable, les caractères sont à peine lisibles. En passant par
Acrobat, et en la faisant tourner dans Acrobat, en zoomant suffisament (i.e.
plus large que l'écran) et en utilisant l'outil de capture instantané, on
arrive à faire une iamge correcte. Néanmoins, cela présente deux
inconvénients: d'une part c'est relativement fastidieux, mais soit, en
revanche, je perds mes liens dynamiques, ce qui est plus genant si entre
temps le comptable a changé des choses.
Aurais-tu une meilleure piste?

Mmmm...Je ne ferai pas de commentaire sur le robot de service.
Concernant la rotation de ton tableau Excel, j'ai retrouvé ça, qui
fonctionnait parfaitement (je ne m'en suis plus servi depuis très longtemps.
Essaie.
Option Explicit

Option Base 1

Dim TabFormules()

Public TotLig As Byte, TotCol As Byte

Dim l As Byte, C As Byte

Sub RotationSurSelection()

Dim L2 As Long, L1 As Long

Dim C1 As Integer, C2 As Integer, N As Byte

Dim F1, Calc As Boolean, Réponse As Long

Calc = Application.Calculation

Application.Calculation = xlCalculationManual

Application.ScreenUpdating = False

Set F1 = ActiveSheet

TotLig = Selection.Rows.Count

TotCol = Selection.Columns.Count

If TotLig = 1 And TotCol = 1 Then

If ActiveCell.CurrentRegion.Cells.Count = 1 Then

MsgBox "Veuillez sélectionner le tableau à transposer !"

Exit Sub

Else

Réponse = MsgBox("Sélection non valide." & Chr(13) & _

"Voulez-vous utiliser la zone en courscomme sélection ?", _

vbYesNo + vbQuestion, "Transposition de tableau")

If Réponse = vbNo Then Exit Sub

ActiveCell.CurrentRegion.Select

TotLig = Selection.Rows.Count

TotCol = Selection.Columns.Count

End If

End If

Call ConversionFormules(TotLig, TotCol)

Sheets.Add.Move After:=Sheets(Worksheets.Count)

ActiveSheet.Name = "Transpose"

F1.Select

Selection.Copy

Sheets("Transpose").Activate

ActiveSheet.Paste Destination:¬tiveSheet.Cells(TotCol + 1, 1)

C1 = 1

For L2 = TotCol + 1 To TotCol + TotLig

C2 = 1

L1 = TotCol

For C2 = 1 To TotCol

Cells(L2, C2).Cut (Cells(L1, C1))

L1 = L1 - 1

Next C2

C1 = C1 + 1

Next L2

With Range("A1").CurrentRegion

..HorizontalAlignment = xlGeneral

..VerticalAlignment = xlBottom

..WrapText = False

..Orientation = 90

..ShrinkToFit = False

..MergeCells = False

..EntireColumn.AutoFit

End With

For C = 1 To Range("A1").CurrentRegion.Columns.Count

For l = 1 To Range("A1").CurrentRegion.Rows.Count

If Range(TabFormules(l, C, 2)).HasFormula = True And (TabFormules(l, C, 4))
Then

Call RemplFormule(l, C)

End If

Next l

Next C

If Calc = True Then Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

End Sub '_________________________________________________



Sub AnnuleRotationSurSelection()

Dim L2 As Long, L1 As Long, N As Byte

Dim C1 As Integer, C2 As Integer, Réponse As Long

Dim F1, Calc As Boolean

Calc = Application.Calculation

Application.Calculation = xlCalculationManual

Application.ScreenUpdating = False

Set F1 = ActiveSheet

TotLig = Selection.Rows.Count

TotCol = Selection.Columns.Count

If TotLig = 1 And TotCol = 1 Then

If ActiveCell.CurrentRegion.Cells.Count = 1 Then

MsgBox "Veuillez sélectionner le tableau à transposer !"

Exit Sub

Else

Réponse = MsgBox("Sélection non valide." & Chr(13) & _

"Voulez-vous utiliser la zone en cours comme sélection ?", _

vbYesNo + vbQuestion, "Annulation de transposition de tableau")

If Réponse = vbNo Then Exit Sub

ActiveCell.CurrentRegion.Select

TotLig = Selection.Rows.Count

TotCol = Selection.Columns.Count

End If

End If

Call AnnConversionFormules(TotLig, TotCol)

Sheets.Add.Move After:=Sheets(Worksheets.Count)

ActiveSheet.Name = "AnnuleTranspose"

F1.Select

Selection.Copy

Sheets("AnnuleTranspose").Activate

ActiveSheet.Paste Destination:¬tiveSheet.Cells(TotCol + 1, 1)

C1 = TotLig

For L2 = TotCol + 1 To TotCol + TotLig

C2 = 1

L1 = 1

For C2 = 1 To TotCol

Cells(L2, C2).Cut (Cells(L1, C1))

L1 = L1 + 1

Next C2

C1 = C1 - 1

Next L2

With Range("A1").CurrentRegion

..HorizontalAlignment = xlGeneral

..VerticalAlignment = xlBottom

..WrapText = False

..Orientation = 0

..ShrinkToFit = False

..MergeCells = False

End With

For C = 1 To Range("A1").CurrentRegion.Columns.Count

For l = 1 To Range("A1").CurrentRegion.Rows.Count

If Range(TabFormules(l, C, 2)).HasFormula = True And (TabFormules(l, C, 4))
Then

Call RemplFormule(l, C)

End If

Next l

Next C

If Calc = True Then Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

End Sub ' __________________________________________________



Sub ConversionFormules(TotLig As Byte, TotCol As Byte)

ReDim TabFormules(TotCol, TotLig, 4)

For C = 1 To TotCol

For l = 1 To TotLig

TabFormules(C, l, 1) = Cells(l, C).Address(0, 0)

TabFormules(C, l, 2) = Cells(TotCol + 1 - C, l).Address(0, 0)

If Cells(l, C).HasFormula = True Then TabFormules(C, l, 3) = Cells(l,
C).FormulaLocal

Next l

Next C

For C = 1 To TotCol

For l = 1 To TotLig

If Not IsEmpty(TabFormules(C, l, 3)) Then

Call Conversion(l, C)

End If

Next l

Next C

End Sub '_________________________________________________



Private Sub Conversion(l As Byte, C As Byte)

Dim U As Integer, V As Integer, W As Integer, X As Integer, Y As Integer, Z
As Integer