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 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112
| Function TransposeTable(SourceData As Object, _
Optional TargetData As Variant, _
Optional LabelRow As String = "Row", _
Optional LabelData As String = "Data", _
Optional LeftColumnNumber As Integer = 1) As Range
' Permet de reconstruire une liste de données présentée comme un tableau de résultats
' Author : Philippe Tulliez
' Version 1.1 (05/07/2013)
' LastDate : 30/06/2014
' Arguments
' SourceData : (Object) - Peut-être de type WorkSheet ou Range
' [TargetData] : (Object)
' [LabelRow] : (String) Nom de l'étiquette de colonne correspondant à la ligne 1 de la zone Data
' [LabelData] : (String) Nom de l'étiquette de colonne correspondant aux données.
' [LeftColumnNumber] : (Integer) indique le nombre de colonne à gauche [d:=1)
' Exemple : Magasin (Colonne 1), Adresse (Colonne 2) ensuite les données LeftColumnNumber doit être 2
' Déclaration des variables
Const ErrTitle As String = "Procédure - TransposeTable":
Dim ErrMsg As String: ErrMsg = "*** Sortie de procédure ***" & vbCrLf & vbCrLf
Dim wkbSource As Workbook, rngSource As Range, rngTarget As Range, rngTable As Range, Row As Long, Table()
Dim flagMove As Boolean
Application.ScreenUpdating = False
' Teste les arguments
' 1er argument (SourceData)
On Error GoTo ErrorHandler
Select Case True
Case TypeOf SourceData Is Worksheet: Set rngSource = SourceData.Range("A1")
Case TypeOf SourceData Is Range: Set rngSource = SourceData
Case Else: Error 10001 ' Déclenchement d'erreur
End Select
Set wkbSource = rngSource.Worksheet.Parent
' 2ème argument (TargetData)
Select Case True
Case IsMissing(TargetData)
With wkbSource
.Sheets.Add After:=.Sheets(.Sheets.Count): flagMove = True ' : Sheets(Sheets.Count).Name = "ExportNew"
Set rngTarget = .Worksheets(.Sheets(.Sheets.Count).Name).Range("A1")
End With
Case TypeOf TargetData Is Worksheet: Set rngTarget = TargetData.Range("A1")
Case TypeOf TargetData Is Range: Set rngTarget = TargetData
Case TypeName(TargetData) = "String"
With wkbSource
On Error Resume Next
Set rngTarget = .Worksheets(TargetData).Range("A1")
If Err Then
.Sheets.Add After:=.Sheets(.Sheets.Count)
With .Sheets(.Sheets.Count): .Name = TargetData: Set rngTarget = .Range("A1"): End With
End If
On Error GoTo 0
End With
On Error GoTo ErrorHandler
Case Else: Error 10002 ' Déclenchement d'erreur
End Select
If rngSource.Parent.Name = rngTarget.Parent.Name Then Error 10003 ' Déclenchement d'erreur
On Error GoTo 0
If rngTarget.CurrentRegion.Count Then rngTarget.Worksheet.Cells.Clear ' Clear Cells
If rngSource.Count = 1 Then
With rngSource.CurrentRegion
Set rngTable = .Offset(, LeftColumnNumber).Resize(, .Columns.Count - LeftColumnNumber)
Set rngSource = .Resize(, LeftColumnNumber)
End With
Else
With rngSource
Set rngTable = .Offset(, LeftColumnNumber).Resize(, .Columns.Count - LeftColumnNumber)
Set rngSource = .Resize(, LeftColumnNumber)
End With
End If
Table = rngTable
' Boucle copie
For Row = 1 To rngTable.Columns.Count
With rngSource
If Row = 1 Then
.Resize(1).Copy rngTarget.Cells(1, 1) ' Copie des étiquettes de colonnes non data
rngTarget.Offset(, .Columns.Count) = LabelRow: rngTarget.Offset(, .Columns.Count + 1) = LabelData
' rngTarget.Offset(, .Columns.Count)
End If
Set rngTarget = rngTarget.Resize(.Rows.Count - 1, .Columns.Count)
rngTarget.Offset(1 + ((Row - 1) * (.Rows.Count - 1))).Value = .Offset(1).Resize(.Rows.Count - 1).Value ' Première colonne
With rngTarget.Offset(1 + ((Row - 1) * (.Rows.Count - 1)), .Columns.Count).Resize(, 1)
.Value = Table(1, Row) ' Première ligne de table
On Error Resume Next: .NumberFormat = rngTable.Cells(Row).NumberFormat
On Error GoTo 0
End With
With rngTarget.Offset(1 + ((Row - 1) * (.Rows.Count - 1)), .Columns.Count + 1).Resize(, 1)
.Value = rngTable.Offset(1, Row - 1).Resize(.Rows.Count, 1).Value
.NumberFormat = rngTable.Offset(1, Row - 1).Resize(1, 1).NumberFormat ' Format de la 1ère cellule de la colonne
End With
End With
Next Row
'
If flagMove Then rngTarget.Worksheet.Move ' Déplacement feuille cible vers nouveau classeur
EndOfProcedure: ' Fin de procédure
Set rngSource = Nothing: Set rngTarget = Nothing: Set rngTable = Nothing
Exit Function
ErrorHandler: ' Interception des erreurs et sortie de fonction
Select Case Err
Case 10001 ' Erreur suite 1er argument
ErrMsg = ErrMsg & "Problème : [SourceData] Objet mal défini (WorkSheet) ou (Range)"
Case 10002 ' Erreur suite 2ème argument
ErrMsg = ErrMsg & "Problème : [TargetData] Objet mal défini (WorkSheet) ou (Range) ou type String"
Case 10003 ' Erreur Feuille Source même que Feuille Target
ErrMsg = ErrMsg & "Problème Feuille : <SheetName>" & vbCrLf & "Arguments [SourceData] & [TargetData] identiques":
ErrMsg = Replace(ErrMsg, "<SheetName>", rngSource.Worksheet.Name)
Case Else
MsgBox "Erreur " & Err.Number & "non gérée"
End Select
' Affichage de l'erreur
On Error GoTo 0
MsgBox Prompt:=ErrMsg, Buttons:=vbCritical, Title:=ErrTitle
GoTo EndOfProcedure
End Function |
Partager