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 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132
|
Sub ExtractTransposeData()
Dim sheetSrc As Worksheet
Dim sheetDst As Worksheet
Dim rSrc As Long
Dim cSrc As Integer
Dim tabData() As String
Dim tabProd() As String
Dim tabSema() As String
Dim nbData As Long
Dim i As Long
Dim j As Long
Dim sem As String
Dim pro As String
Dim mac As String
Dim sep As String
Dim c As Integer
Dim r As Long
On Error GoTo lblErr
Application.ScreenUpdating = False
'Mettre les données de la feuille Excel dans un tableau
Set sheetSrc = ThisWorkbook.Worksheets("Feuil1")
cSrc = 2
i = 0
While sheetSrc.Cells(1, cSrc) > "" 'Parcourir les Semaines
rSrc = 2
While sheetSrc.Cells(rSrc, 1) > "" 'Parcourir les Machines
If sheetSrc.Cells(rSrc, cSrc) > "" Then 'Alimenter le tableau si un Produit est présent
i = i + 1
ReDim Preserve tabData(3, i)
tabData(1, i - 1) = sheetSrc.Cells(1, cSrc) 'Semaine
tabData(2, i - 1) = sheetSrc.Cells(rSrc, cSrc) 'Produit
tabData(3, i - 1) = sheetSrc.Cells(rSrc, 1) 'Machine
End If
rSrc = rSrc + 1
Wend
cSrc = cSrc + 1
Wend
Set sheetSrc = Nothing
nbData = i
'Dresser la liste des Semaines
For i = 0 To nbData - 1
ReDim Preserve tabSema(i + 1)
tabSema(i) = tabData(1, i)
Next i
'Trier le tableau des Semaines
For i = 0 To UBound(tabSema) - 1
For j = i To UBound(tabSema) - 1
If UCase(tabSema(j)) < UCase(tabSema(i)) Then
sem = tabSema(i)
tabSema(i) = tabSema(j)
tabSema(j) = sem
End If
Next j
Next i
'Dresser la liste des Produits
For i = 0 To nbData - 1
ReDim Preserve tabProd(i + 1)
tabProd(i) = tabData(2, i)
Next i
'Trier le tableau des Produits
For i = 0 To UBound(tabProd) - 1
For j = i To UBound(tabProd) - 1
If UCase(tabProd(j)) < UCase(tabProd(i)) Then
prod = tabProd(i)
tabProd(i) = tabProd(j)
tabProd(j) = prod
End If
Next j
Next i
'Remplir une nouvelle feuille en transposant les données
Set sheetDst = ThisWorkbook.Worksheets("Feuil2")
'Ajouter les Semaines en Colonne
r = 1
sem = 0
For i = 0 To UBound(tabSema) - 1
If sem <> tabSema(i) Then
c = c + 1
sem = tabSema(i)
sheetDst.Cells(1, c) = sem
End If
Next i
'Ajouter les Produits en Ligne
c = 1
pro = ""
For i = 0 To UBound(tabProd) - 1
If pro <> tabProd(i) Then
r = r + 1
pro = tabProd(i)
sheetDst.Cells(r, 1) = pro
End If
Next i
'Ajouter les Machines à l'intersection des Semaines/Produits
c = 2
While sheetDst.Cells(1, c) > ""
sem = sheetDst.Cells(1, c)
r = 2
While sheetDst.Cells(r, 1) > ""
prod = sheetDst.Cells(r, 1)
mac = ""
sep = ""
For i = 0 To nbData - 1
If tabData(1, i) = sem Then
If tabData(2, i) = prod Then
mac = mac & sep & tabData(3, i)
sep = ";"
End If
End If
Next i
sheetDst.Cells(r, c) = mac
r = r + 1
Wend
c = c + 1
Wend
GoTo lblFin
lblErr:
MsgBox Err.Description
lblFin:
Set sheetDst = Nothing
Application.ScreenUpdating = True
End Sub |
Partager