Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- ' V0.3.3
- Sub ATransposeTable()
- Dim margeGauche As Integer
- Dim margeHaut As Integer
- Dim ecartMatricesGenerees
- Dim ecart12 As Integer
- Dim ecartMoyenneMediane As Integer
- Dim espaceTitreTableau As Integer
- Dim ecartEchelle As Integer
- Dim selectedRange As Range
- Set selectedRange = selection
- ' //////////Réglage des écartements :\\\\\\\\\\
- ' Marge générale à gauche
- margeGauche = 1
- ' Marge générale en haut
- margeHaut = 1
- ' Ecartement horizontal des matrices renversées
- ecartMatricesGenerees = 2
- ' Ecart horizontal entre les matrices avec et sans chiffres
- ecart12 = 1
- 'Ecart horizontal entre les blocs Mediane et Moyenne
- ecartMoyenneMediane = 6
- ' Marge verticale des séries de matrices
- espaceTitreTableau = 3
- ' Marge horizontale entre matrice invisible et échelle
- ecartEchelle = 1
- ' //////////Enregistrement des références :\\\\\\\\\\
- Dim firstRowSize As Integer
- Dim indexFirstRow As Integer
- Dim indexLastRow As Integer
- Dim firstColSize As Integer
- Dim indexFirstCol As Integer
- Dim indexLastCol As Integer
- firstRowSize = selectedRange.Rows.Count
- indexFirstRow = selectedRange.Cells(0, 0).Row + 1
- indexLastRow = indexFirstRow + firstRowSize
- firstColSize = selectedRange.Columns.Count
- indexFirstCol = selectedRange.Cells(0, 0).Column + 1
- indexLastCol = indexFirstCol + firstColSize
- ' //////////Renversement des matrices :\\\\\\\\\\
- ' Remplace les cases vides par NaN dans la matrice initiale
- Dim cell As Range
- For Each cell In selectedRange
- If cell.Value = "" Then
- cell.Value = "NaN"
- End If
- Next cell
- ' Transpose la plage de données sélectionnée
- Dim transposedRange As Range
- Set transposedRange = ActiveSheet.Cells(indexFirstRow, indexLastCol + ecartMatricesGenerees).Resize(firstColSize, firstRowSize)
- ' Boucle à travers les cellules de la plage originale
- For i = 1 To firstRowSize
- For j = 1 To firstColSize
- ' Copiez la valeur de la cellule originale dans la cellule transposée correspondante
- transposedRange.Cells(j, i).Value = selectedRange.Cells(i, j).Value
- Next j
- Next i
- ' Inverser l'ordre des lignes
- Dim invertedRange As Range
- Set invertedRange = transposedRange.Offset(0, firstRowSize + ecartMatricesGenerees)
- For i = 1 To transposedRange.Rows.Count
- For j = 1 To transposedRange.Columns.Count
- invertedRange.Cells(i, j).Value = transposedRange.Cells(transposedRange.Rows.Count + 1 - i, j).Value
- Next j
- Next i
- ' //////////Création des matrices de présentation :\\\\\\\\\\
- ' Détermine où commencer les matrices selon les dimensions de la map
- Dim rowSize As Integer
- Dim colSize As Integer
- Dim indexFirstPresRow As Integer
- rowSize = firstColSize
- colSize = firstRowSize
- If firstColSize > firstRowSize Then
- indexFirstPresRow = margeHaut + firstColSize + espaceTitreTableau + 1
- Else
- indexFirstPresRow = margeHaut + firstRowSize + espaceTitreTableau + 1
- End If
- Dim scaleColSize As Integer
- scaleColSize = 2
- ' Valeurs brutes
- Dim bruteMediane1 As Range
- Set bruteMediane1 = ActiveSheet.Cells(indexFirstPresRow, indexFirstCol).Resize(rowSize, colSize)
- bruteMediane1.BorderAround _
- ColorIndex:=xlAutomatic, Weight:=xlThin
- For i = 1 To rowSize
- For j = 1 To colSize
- bruteMediane1.Cells(i, j).Value = invertedRange.Cells(i, j).Value
- bruteMediane1.Cells(i, j).HorizontalAlignment = xlCenter
- bruteMediane1.Cells(i, j).VerticalAlignment = xlCenter
- Next j
- Next i
- Dim bruteMediane2 As Range
- Set bruteMediane2 = bruteMediane1.Offset(0, colSize + ecart12)
- bruteMediane2.BorderAround _
- ColorIndex:=xlAutomatic, Weight:=xlThin
- For i = 1 To rowSize
- For j = 1 To colSize
- bruteMediane2.Cells(i, j).Value = invertedRange.Cells(i, j).Value
- bruteMediane2.Cells(i, j).HorizontalAlignment = xlCenter
- bruteMediane2.Cells(i, j).VerticalAlignment = xlCenter
- bruteMediane2.Cells(i, j).NumberFormat = ";;;"
- Next j
- bruteMediane2.Cells(i, j + ecartEchelle).NumberFormat = ";;;"
- Next i
- Dim zoneEchelleBruteMediane As Range
- Set zoneEchelleBruteMediane = ActiveSheet.Cells(indexFirstPresRow + 1, indexFirstCol + colSize + ecart12 + colSize + 1 + 1).Resize(rowSize, scaleColSize)
- Call GenererEchelle(zoneEchelleBruteMediane)
- Dim zoneAColorer As Range
- Set zoneAColorer = ActiveSheet.Cells(indexFirstPresRow, indexFirstCol).Resize(rowSize, colSize + ecart12 + colSize + ecartEchelle + 1)
- Call ColorerMatrices(zoneAColorer, "med")
- Dim bruteMoyenne1 As Range
- Set bruteMoyenne1 = bruteMediane2.Offset(0, colSize + ecartMoyenneMediane)
- bruteMoyenne1.BorderAround _
- ColorIndex:=xlAutomatic, Weight:=xlThin
- For i = 1 To rowSize
- For j = 1 To colSize
- bruteMoyenne1.Cells(i, j).Value = invertedRange.Cells(i, j).Value
- bruteMoyenne1.Cells(i, j).HorizontalAlignment = xlCenter
- bruteMoyenne1.Cells(i, j).VerticalAlignment = xlCenter
- Next j
- Next i
- Dim bruteMoyenne2 As Range
- Set bruteMoyenne2 = bruteMoyenne1.Offset(0, colSize + ecart12)
- bruteMoyenne2.BorderAround _
- ColorIndex:=xlAutomatic, Weight:=xlThin
- For i = 1 To rowSize
- For j = 1 To colSize
- bruteMoyenne2.Cells(i, j).Value = invertedRange.Cells(i, j).Value
- bruteMoyenne2.Cells(i, j).HorizontalAlignment = xlCenter
- bruteMoyenne2.Cells(i, j).VerticalAlignment = xlCenter
- bruteMoyenne2.Cells(i, j).NumberFormat = ";;;"
- Next j
- bruteMoyenne2.Cells(i, j + ecartEchelle).NumberFormat = ";;;"
- Next i
- Dim zoneEchelleBruteMoyenne As Range
- Set zoneEchelleBruteMoyenne = ActiveSheet.Cells(indexFirstPresRow + 1, indexFirstCol + colSize + ecart12 + colSize + ecartMoyenneMediane + colSize + ecart12 + colSize + 1 + 1).Resize(rowSize, scaleColSize)
- Call GenererEchelle(zoneEchelleBruteMoyenne)
- Call ColorerMatrices(zoneAColorer.Offset(0, colSize + ecart12 + colSize + ecartMoyenneMediane), "moy")
- ' Valeurs modifiées
- Dim reponse As Integer
- reponse = MsgBox("Ecraser les matrices modifiées ?", vbYesNo)
- If reponse = vbYes Then
- Dim modifMediane1 As Range
- Set modifMediane1 = bruteMediane1.Offset(rowSize + espaceTitreTableau, 0)
- modifMediane1.BorderAround _
- ColorIndex:=xlAutomatic, Weight:=xlThin
- For i = 1 To rowSize
- For j = 1 To colSize
- modifMediane1.Cells(i, j).Value = invertedRange.Cells(i, j).Value
- modifMediane1.Cells(i, j).HorizontalAlignment = xlCenter
- modifMediane1.Cells(i, j).VerticalAlignment = xlCenter
- Next j
- Next i
- Dim modifMediane2 As Range
- Set modifMediane2 = bruteMediane2.Offset(rowSize + espaceTitreTableau, 0)
- modifMediane2.BorderAround _
- ColorIndex:=xlAutomatic, Weight:=xlThin
- For i = 1 To rowSize
- For j = 1 To colSize
- modifMediane2.Cells(i, j).Value = invertedRange.Cells(i, j).Value
- modifMediane2.Cells(i, j).HorizontalAlignment = xlCenter
- modifMediane2.Cells(i, j).VerticalAlignment = xlCenter
- modifMediane2.Cells(i, j).NumberFormat = ";;;"
- Next j
- modifMediane2.Cells(i, j + ecartEchelle).NumberFormat = ";;;"
- Next i
- Call GenererEchelle(zoneEchelleBruteMediane.Offset(rowSize + espaceTitreTableau, 0))
- Call ColorerMatrices(zoneAColorer.Offset(rowSize + espaceTitreTableau, 0), "med")
- Dim modifMoyenne1 As Range
- Set modifMoyenne1 = bruteMoyenne1.Offset(rowSize + espaceTitreTableau, 0)
- modifMoyenne1.BorderAround _
- ColorIndex:=xlAutomatic, Weight:=xlThin
- For i = 1 To rowSize
- For j = 1 To colSize
- modifMoyenne1.Cells(i, j).Value = invertedRange.Cells(i, j).Value
- modifMoyenne1.Cells(i, j).HorizontalAlignment = xlCenter
- modifMoyenne1.Cells(i, j).VerticalAlignment = xlCenter
- Next j
- Next i
- Dim modifMoyenne2 As Range
- Set modifMoyenne2 = bruteMoyenne2.Offset(rowSize + espaceTitreTableau, 0)
- modifMoyenne2.BorderAround _
- ColorIndex:=xlAutomatic, Weight:=xlThin
- For i = 1 To rowSize
- For j = 1 To colSize
- modifMoyenne2.Cells(i, j).Value = invertedRange.Cells(i, j).Value
- modifMoyenne2.Cells(i, j).HorizontalAlignment = xlCenter
- modifMoyenne2.Cells(i, j).VerticalAlignment = xlCenter
- modifMoyenne2.Cells(i, j).NumberFormat = ";;;"
- Next j
- modifMoyenne2.Cells(i, j + ecartEchelle).NumberFormat = ";;;"
- Next i
- Call GenererEchelle(zoneEchelleBruteMoyenne.Offset(rowSize + espaceTitreTableau, 0))
- Call ColorerMatrices(zoneAColorer.Offset(rowSize + espaceTitreTableau, colSize + ecart12 + colSize + ecartMoyenneMediane), "moy")
- End If
- End Sub
- Sub ExtraireValeurs()
- 'Déclaration des variables
- Dim selectedRange As Range
- Set selectedRange = selection
- Dim cell As Range
- Dim ecriture As Range
- Set ecriture = Application.InputBox("Selectionne la case d'écriture", Type:=8)
- 'Parcourir chaque cellule dans la sélection
- Dim i As Integer
- i = ecriture.Row
- For Each cell In selectedRange
- 'Copier la valeur de la cellule dans la colonne I à partir de l'adresse I65
- Cells(i, ecriture.Column).Value = cell.Value
- i = i + 1
- Next cell
- End Sub
- Sub GenererEchelle(zoneEchelle As Range)
- Dim maxEchelle As Integer
- Dim minEchelle As Integer
- Dim pasEchelle As Integer
- Select Case Left(ActiveSheet.Name, 1)
- Case "s", "S"
- maxEchelle = 3000
- minEchelle = 200
- pasEchelle = 200
- Case "y", "Y"
- maxEchelle = 1000
- minEchelle = 0
- pasEchelle = 100
- Case "l", "L"
- maxEchelle = 1600
- minEchelle = 100
- pasEchelle = 100
- Case Else
- MsgBox "Le nom de l'onglet ne commence pas par 's', 'y' ou 'l'."
- End Select
- Dim echelleRowSize As Integer
- echelleRowSize = (maxEchelle - minEchelle) / pasEchelle + 1
- Dim echelleCouleurs As Range
- Set echelleCouleurs = zoneEchelle.Cells(0, 0).Resize(echelleRowSize, 1)
- echelleCouleurs.Borders(xlDiagonalDown).LineStyle = xlNone
- echelleCouleurs.Borders(xlDiagonalUp).LineStyle = xlNone
- With echelleCouleurs.Borders(xlEdgeLeft)
- .LineStyle = xlContinuous
- .ColorIndex = 0
- .TintAndShade = 0
- .Weight = xlThin
- End With
- With echelleCouleurs.Borders(xlEdgeTop)
- .LineStyle = xlContinuous
- .ColorIndex = 0
- .TintAndShade = 0
- .Weight = xlThin
- End With
- With echelleCouleurs.Borders(xlEdgeBottom)
- .LineStyle = xlContinuous
- .ColorIndex = 0
- .TintAndShade = 0
- .Weight = xlThin
- End With
- With echelleCouleurs.Borders(xlEdgeRight)
- .LineStyle = xlContinuous
- .ColorIndex = 0
- .TintAndShade = 0
- .Weight = xlThin
- End With
- echelleCouleurs.Borders(xlInsideVertical).LineStyle = xlNone
- echelleCouleurs.Borders(xlInsideHorizontal).LineStyle = xlNone
- Dim cell As Range
- For Each cell In echelleCouleurs
- cell.Formula = "=" + cell.Offset(0, 1).Address
- Next cell
- Dim echelleValeurs As Range
- Set echelleValeurs = zoneEchelle.Cells(0, 1).Resize(echelleRowSize, 1)
- With echelleValeurs.Interior
- .Pattern = xlSolid
- .PatternColorIndex = xlAutomatic
- .ThemeColor = xlThemeColorDark1
- .TintAndShade = 0
- .PatternTintAndShade = 0
- End With
- With echelleValeurs.Font
- .Name = "Calibri"
- .Size = 14
- .Strikethrough = False
- .Superscript = False
- .Subscript = False
- .OutlineFont = False
- .Shadow = False
- .Underline = xlUnderlineStyleNone
- .ThemeColor = xlThemeColorLight1
- .TintAndShade = 0
- .ThemeFont = xlThemeFontMinor
- End With
- With echelleValeurs
- .HorizontalAlignment = xlGeneral
- .VerticalAlignment = xlCenter
- .WrapText = False
- .Orientation = 0
- .AddIndent = False
- .IndentLevel = 0
- .ShrinkToFit = False
- .ReadingOrder = xlContext
- .MergeCells = False
- End With
- With echelleValeurs
- .HorizontalAlignment = xlCenter
- .VerticalAlignment = xlCenter
- .WrapText = False
- .Orientation = 0
- .AddIndent = False
- .IndentLevel = 0
- .ShrinkToFit = False
- .ReadingOrder = xlContext
- .MergeCells = False
- End With
- Dim currentEchelle As Integer
- currentEchelle = maxEchelle
- For Each cell In echelleValeurs
- cell.Value = currentEchelle
- currentEchelle = currentEchelle - pasEchelle
- Next cell
- End Sub
- Sub ColorerMatrices(zoneAColorer As Range, medMoy As String)
- Dim monType As XlConditionValueTypes
- If medMoy = "med" Then
- monType = xlConditionValuePercentile
- ElseIf medMoy = "moy" Then
- monType = xlConditionValuePercent
- End If
- Dim themeColor1 As XlThemeColor
- Dim themeColor2 As XlThemeColor
- Dim themeColor3 As XlThemeColor
- Dim tintShade1 As Double
- Dim tintShade2 As Double
- Dim tintShade3 As Double
- Select Case Left(ActiveSheet.Name, 1)
- Case "s", "S"
- themeColor1 = xlThemeColorAccent1
- themeColor2 = xlThemeColorAccent4
- themeColor3 = xlThemeColorAccent2
- tintShade1 = 0.399975585192419
- tintShade2 = 0.799981688894314
- tintShade3 = 0
- Case "y", "Y"
- themeColor1 = 10066176
- themeColor2 = xlThemeColorAccent4
- themeColor3 = 13260
- tintShade1 = 0
- tintShade2 = 0.599993896298105
- tintShade3 = 0
- Case "l", "L"
- themeColor1 = xlThemeColorDark1
- themeColor2 = xlThemeColorAccent4
- themeColor3 = xlThemeColorAccent2
- tintShade1 = -0.499984740745262
- tintShade2 = 0.799981688894314
- tintShade3 = 0
- Case Else
- MsgBox "Le nom de l'onglet ne commence pas par 's', 'y' ou 'l'."
- End Select
- zoneAColorer.FormatConditions.AddColorScale ColorScaleType:=3
- zoneAColorer.FormatConditions(zoneAColorer.FormatConditions.Count).SetFirstPriority
- zoneAColorer.FormatConditions(1).colorScaleCriteria(1).Type = _
- xlConditionValueLowestValue
- Select Case Left(ActiveSheet.Name, 1)
- Case "s", "S", "l", "L"
- With zoneAColorer.FormatConditions(1).colorScaleCriteria(1).FormatColor
- .ThemeColor = themeColor1
- .TintAndShade = tintShade1
- End With
- zoneAColorer.FormatConditions(1).colorScaleCriteria(2).Type = _
- monType
- zoneAColorer.FormatConditions(1).colorScaleCriteria(2).Value = 50
- With zoneAColorer.FormatConditions(1).colorScaleCriteria(2).FormatColor
- .ThemeColor = themeColor2
- .TintAndShade = tintShade2
- End With
- zoneAColorer.FormatConditions(1).colorScaleCriteria(3).Type = _
- xlConditionValueHighestValue
- With zoneAColorer.FormatConditions(1).colorScaleCriteria(3).FormatColor
- .ThemeColor = themeColor3
- .TintAndShade = tintShade3
- End With
- Case "y", "Y"
- With zoneAColorer.FormatConditions(1).colorScaleCriteria(1).FormatColor
- .Color = themeColor1
- .TintAndShade = tintShade1
- End With
- zoneAColorer.FormatConditions(1).colorScaleCriteria(2).Type = _
- monType
- zoneAColorer.FormatConditions(1).colorScaleCriteria(2).Value = 50
- With zoneAColorer.FormatConditions(1).colorScaleCriteria(2).FormatColor
- .ThemeColor = themeColor2
- .TintAndShade = tintShade2
- End With
- zoneAColorer.FormatConditions(1).colorScaleCriteria(3).Type = _
- xlConditionValueHighestValue
- With zoneAColorer.FormatConditions(1).colorScaleCriteria(3).FormatColor
- .Color = themeColor3
- .TintAndShade = tintShade3
- End With
- End Select
- End Sub
- ' //////////Changelog :\\\\\\\\\\
- ' V0.2 : Encadre les matrices de présentation
- ' V0.2.1 : Centre verticalement les valeurs des matrices de presentation
- ' V0.3 : Nettoyage du code de placement des matrices de présentation; Ajout des échelles et coloration des matrices
- ' V0.3.1 : Gère la coloration différenciée entre médiane et moyenne; Gere des couleurs différentes selon que l'onglet commence par "l" ou par "s"
- ' V0.3.2 : Gère la coloration pour l'onglet "y"
- ' V0.3.3 : Change min max et pas sur l'échelle selon onglet
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement