Retour à la FAQ

Je te joins ci-après deux macros :
la première permet de faire faire une rotation à 90° à un tableau Excel, en conservant les formules, la seconde permet d'annuler la rotation.
Ces macros, qui seront surtout utiles aux utilisateurs de Word, ont été mises au point par plusieurs personnes, dans lesquelles on trouve l'irremplacable Laurent (Longre, bien sûr), Isabelle, et surtout Benoît Marchand, que je remercie. Cordialement, André

Sub RotationSurSelection()
Dim L As Long, C As Integer, L2 As Long, L1 As Long
Dim C1 As Integer, C2 As Integer
Dim F1, Calc As Boolean, Réponse As Long

Calc = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set F1 = ActiveSheet
L = Selection.Rows.Count
C = Selection.Columns.Count

If C = 1 And L = 1 Then
If ActiveSheet.UsedRange.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 étendre la sélection ?", _
vbYesNo + vbQuestion, "Transposition de tableau")

If Réponse = vbNo Then Exit Sub
ActiveSheet.UsedRange.Select
L = Selection.Rows.Count
C = Selection.Columns.Count
End If
End If

Sheets.Add.Move After:=Sheets(Worksheets.Count)
ActiveSheet.Name = "Transpose"
F1.Select
Selection.Copy
Sheets("Transpose").Activate
ActiveSheet.Paste Destination:=ActiveSheet.Cells(C + 1, 1)
C1 = 1
For L2 = C + 1 To C + L
C2 = 1
L1 = C
For C2 = 1 To C
Cells(L2, C2).Cut (Cells(L1, C1))
L1 = L1 - 1
Next C2
C1 = C1 + 1
Next L2

With ActiveSheet.UsedRange
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 90
.ShrinkToFit = False
.MergeCells = False
.EntireColumn.AutoFit
End With

If Calc = True Then Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

'_________________________________________________

Sub AnnuleRotationSurSelection()
Dim L As Long, C As Integer, L2 As Long, L1 As Long
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
L = Selection.Rows.Count
C = Selection.Columns.Count

If C = 1 And L = 1 Then
If ActiveSheet.UsedRange.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 étendre la sélection ?", _
vbYesNo + vbQuestion, "Annulation de transposition de tableau")
If Réponse = vbNo Then Exit Sub
ActiveSheet.UsedRange.Select
L = Selection.Rows.Count
C = Selection.Columns.Count
End If
End If

Sheets.Add.Move After:=Sheets(Worksheets.Count)
ActiveSheet.Name = "Retranspose"
F1.Select
Selection.Copy
Sheets("Retranspose").Activate
ActiveSheet.Paste Destination:=ActiveSheet.Cells(C + 1, 1)
C1 = L
For L2 = C + 1 To C + L
C2 = 1
L1 = 1
For C2 = 1 To C
Cells(L2, C2).Cut (Cells(L1, C1))
L1 = L1 + 1
Next C2
C1 = C1 - 1
Next L2

With ActiveSheet.UsedRange
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.ShrinkToFit = False
.MergeCells = False
End With

If Calc = True Then Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

[top]