VBA - Synthèse avec transposition H-->V
Bonjour à tous,
Je sollicite votre aide pour une macro en VBA qui effectuerait une synthèse horizontale --> verticale selon des données (Nbre de jours >0).
J'ai réalisé un fichier exemple avec deux onglets : résultat initial et résultat souhaité afin d'aider à la compréhension.
Merci par avance pour vos contributions.
Bien cordialement.
Christophe.
Bonjour,
A vori si cela convient :
Sub TransposerTablo()
Dim T(), n%, i%, j%, k%, h%
With Worksheets("Résultat initial")
n = .Cells(.Rows.Count, 1).End(xlUp).Row
ReDim T(5, (n - 1) * 3)
For i = 1 To 5
T(i - 1, 0) = .Cells(1, i)
Next i
T(5, 0) = .Cells(1, 12)
For i = 2 To n
For j = 3 To 9 Step 3
If .Cells(i, j) > 0 Then
k = k + 1: T(0, k) = .Cells(i, 1): T(1, k) = .Cells(i, 2)
For h = 0 To 2
T(2 + h, k) = .Cells(i, j + h)
Next h
T(5, k) = .Cells(i, 12)
End If
Next j
Next i
End With
If k = 0 Then Exit Sub
ReDim Preserve T(5, k)
With Worksheets("Résultat souhaité").Range("A1")
.CurrentRegion.Clear
With .Resize(k + 1, 6)
.Value = WorksheetFunction.Transpose(T)
.HorizontalAlignment = xlCenter
.Borders.Weight = xlThin
.Rows(1).Font.Bold = True
.Columns(3).NumberFormat = "#\ #00"
.Columns(4).NumberFormat = "#\ ## 000"
.Columns(5).NumberFormat = "0.00"
.Rows(1).Columns.AutoFit
.Columns(2).AutoFit
End With
.Worksheet.Activate
End With
End SubCordialement.
Bonjour MFerrand,
C'est tout simplement génial, cela fonctionne parfaitement j'ai pu l'intégrer dans mon projet.
Juste une dernière chose, comment faire pour obtenir un triage du plus petit au plus grand de la colonne A une fois la synthèse effectuée ?
Merci encore.
Christophe.
[...]
With .Resize(k + 1, 6)
[...]
.Sort key1:= .Cells(1, 1), order1:= xlAscending, Header:= xlYes
End With
[...]Voilà pour trier à la fin...
Bonne continuation.
C'est parfait.
Un grand merci, bonne après-midi.
Christophe.
Pour l'après-midi c'est déjà du passé, la nuit arrive tout doucement !
Bonne soirée à toi.
Bonsoir MFerrand,
Je reviens à la charge avec un petit tableau beaucoup plus simple a transposer.
Avant de demander j'ai tenter d'adapter ta première formule sans succès.
La transposition à l'air beaucoup plus simple.
Merci pour ton aide.
Christophe.
Bonjour,
Le résultat initial et le résultat final souhaité sont identiques ! Qu'en est-il ?
Cordialement.
Bonjour MFerrand,
Effectivement, ils sont identique.
Il faudrait que la macro sélectionne de "A2" à "D2" tant qu'il y a des données verticalement et les transpose dans l'onglet résulta souhaité.
Une sorte de copié collé.
Merci encore.
Je suis dubitatif devant ta demande !
Worksheets("Résultat souhaité").Range("A2:D4").Value = Worksheets("Résultat initial").Range("A2:D4").ValueCordialement.
MFerrand a écrit :Je suis dubitatif devant ta demande !
Car rien à transposer ou modifier dans ce cas ! Worksheets("Résultat souhaité").Range("A2:D4").Value = Worksheets("Résultat initial").Range("A2:D4").ValueCordialement.
En fait je me suis mal exprimé
Il faudrait que la macro transpose le contenu de "Résultat initial" à partir de la cellule A2 jusqu'a D puis verticalement tant qu'il y a des données vers l'onglet "Résultat souhaité"
Cela peut être A2-D58 - A2-D104 - A2-DXX etc... le nombre de ligne est variable.
Je sais pas si je m'explique comme il faut
Merci encore.
Il faudrait que la macro transpose le contenu de "Résultat initial" à partir de la cellule A2 jusqu'a D puis verticalement tant qu'il y a des données vers l'onglet "Résultat souhaité"
Illustre-moi donc ça ! Pas à pas s'il le faut !
Bonjour,
Ne t'ennuie plus avec ceci, j'ai bidouillé quelque chose.
Merci encore pour d'avoir pris a peine de regarde tout ceci
Je te montre tout de même.
Ce doit être perfectible
Sub Synthese_1453()
Dim NbLg As Long, Ligne As Long
Dim WsL As Worksheet, Ws As Worksheet
Dim Cel As Range, Kase As Range
Dim LesFeuilles
Dim i As Integer, Colonne As Integer
ActiveWorkbook.Unprotect Password:="200997"
Application.ScreenUpdating = False
Set Ws = Sheets("Saisie_masse_1453_SIRH")
Ws.Unprotect Password:="200997"
Ws.Range("A2:L" & Rows.Count).ClearContents
Ligne = 1
Set WsL = Sheets("Liste complète des PERS DIR")
LesFeuilles = Array("Indem horaire travail DJF")
For i = 0 To UBound(LesFeuilles)
With Sheets(LesFeuilles(i))
.Unprotect Password:="200997"
NbLg = .Range("B" & Rows.Count).End(xlUp).Row + 1
If i = 2 Then Colonne = 8 Else Colonne = 8
.Range(.Cells(17, Colonne), .Cells(NbLg, Colonne)).AutoFilter field:=1, Criteria1:=">0"
'.Range("L17:L" & NbLg).AutoFilter field:=1, Criteria1:=">0"
If Application.Subtotal(103, .Range("B18:B" & NbLg)) > 0 Then
For Each Cel In .Range("B18:B" & NbLg).SpecialCells(xlCellTypeVisible)
If Cel <> "" Then
Set Kase = WsL.Columns("A").Find(what:=Replace(Replace(Cel, " ", ""), "|", ""), LookIn:=xlValues, lookat:=xlPart)
If Not Kase Is Nothing Then
Ligne = Ligne + 1
'Récupération des données
Ws.Range("A" & Ligne) = Cel.Offset(0, 7)
Ws.Range("B" & Ligne) = Kase.Offset(0, 1) & "," & Kase.Offset(0, 2)
Ws.Range("C" & Ligne) = Cel.Offset(0, 8)
Ws.Range("D" & Ligne) = Cel.Offset(0, 9)
'Ws.Range("E" & Ligne) = Cel.Offset(0, 14)
'Ws.Range("F" & Ligne) = Cel.Offset(0, 15)
' Ws.Range("G" & Ligne) = Cel.Offset(0, 16)
' Ws.Range("H" & Ligne) = Cel.Offset(0, 17)
' Ws.Range("I" & Ligne) = Cel.Offset(0, 18)
' Ws.Range("J" & Ligne) = Cel.Offset(0, 19)
'Ws.Range("K" & Ligne) = Cel.Offset(0, 20)
'Ws.Range("L" & Ligne) = .Range("A1")
'Mise en forme des données
Ws.Range("C2:C" & NbLg).NumberFormat = "# #0,0"
Ws.Range("D2:D" & NbLg).NumberFormat = "0.00"
'Range("E2:E" & NbLg).NumberFormat = "0.00"
'Range("F2:F" & NbLg).NumberFormat = "# #0,0"
' Range("G2:G" & NbLg).NumberFormat = "# ##0,00"
' Range("H2:H" & NbLg).NumberFormat = "0.00"
' Range("I2:I" & NbLg).NumberFormat = "# #0,0"
' Range("J2:J" & NbLg).NumberFormat = "# ##0,00"
' Range("K2:K" & NbLg).NumberFormat = "0.00"
'Ws.Range("A2:D" & NbLg).HorizontalAlignment = xlCenter
'Ws.Range("A2:D" & NbLg).VerticalAlignment = xlCenter
'Ws.Range("A2:D" & NbLg).Font.Name = "Arial"
'Ws.Range("A2:D" & NbLg).Borders.Weight = xlThin
'Ws.Range("A" & Ligne) = Kase
'Ws.Range("B" & Ligne) = Kase.Offset(0, 1) & "," & Kase.Offset(0, 2)
'Ws.Range("C" & Ligne) = .Range("M2")
'Ws.Range("D" & Ligne) = .Range("N3")
'Ws.Range("E" & Ligne) = CDate(.Range("E12"))
'Ws.Range("F" & Ligne) = .Cells(Cel.Row, Colonne) * 100 'Cel.Offset(0, 10)
Else
MsgBox "Code " & Cel & " introuvable"
End If
End If
Next Cel
End If
.AutoFilterMode = False
.Protect Password:="200997"
ActiveWorkbook.Protect Password:="200997"
End With
Next i
If Ws.[A65536].End(xlUp).Row > 1 Then InjectionGlobal_1453: MsgBox "Export pour SIRH HARMONIE effectué"
'InjectionGlobal_1453
End Sub
Sub InjectionGlobal_1453()
Dim Chemin As String, Fichier As String
Dim Ws As Worksheet
Dim NbLg As Long
ActiveWorkbook.Unprotect Password:="200997"
Application.ScreenUpdating = False
Set Ws = Sheets("Saisie_masse_1453_SIRH")
If Ws.Range("A2") = "" Then Exit Sub
Chemin = ThisWorkbook.Path & Application.PathSeparator
Fichier = "Saisie_masse_1453_SIRH.xlsx"
If Dir(Chemin & Fichier) = "" Then
Ws.Visible = xlSheetVisible
Ws.Copy
Ws.Visible = xlSheetHidden
ActiveSheet.DrawingObjects.Delete
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Chemin & Fichier, FileFormat:=xlOpenXMLWorkbook
Application.DisplayAlerts = True
ActiveWorkbook.Close
Else
NbLg = Ws.Range("A" & Rows.Count).End(xlUp).Row
If NbLg > 1 Then
With Workbooks.Open(Chemin & Fichier)
Ws.Range("A2:D" & NbLg).Copy .Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Close savechanges:=True
End With
End If
End If
ActiveWorkbook.Protect Password:="200997"
End SubChristophe.