Macro VBA
Bonjour,
J'aimerai concevoir une macros qui prend chaque lignes du tableau et les transformes en une seule colonne, en les imbriquant en structure ABAB.
Si vous avez des pistes ?
Cordialement,
Bonjour et bienvenue sur le forum
Tu devrais joindre un fichier donnant un exemple de tableau et de ce que tu veux en faire...
Bye !
Bonjour,
Voici un fichier que j'aimerai automatiser avec une macros on part de la feuille 1 pour arriver a la structure de la feuille2.
Slt medmed94,
à tester:
Sub transformerenColonne()
Dim x As Worksheet, y As Worksheet
Dim i As Integer, j As Integer, lastrow_x As Integer, lastrow_y As Integer, lastcol_x As Integer
Dim z As Range
Set x = ThisWorkbook.Sheets(1)
Set y = ThisWorkbook.Sheets(2)
Set z = x.UsedRange
lastrow_x = z.Rows.Count
lastcol_x = z.Columns.Count
lastrow_y = y.Range("A1").Rows.Count
For i = 1 To lastrow_x - 1
For j = 1 To lastcol_x
If x.Cells(i, j).Value <> 0 Then
y.Cells(lastrow_y, 1).Value = x.Cells(1, j).Value
y.Cells(lastrow_y + 1, 1).Value = x.Cells(i + 1, j).Value
lastrow_y = lastrow_y + 2
End If
Next j
Next i
y.Columns("A").Cells.HorizontalAlignment = xlCenter
y.Columns("A").EntireColumn.AutoFit
End SubBonsoir m3allem,
Merci bcp pour ta macros c’est super !
Cordialement.
Bonjour,
Je vous remercie a tous pour l'aide que vous m'apporter c'est très gentil de votre part j'aimerai arrivé a ce schéma avec une macros s'il vous plait.
Comme sur l'autre je partirai de la feuille 1 vers la feuille 2.
cordialement.
Slt medmed,
à tester
Sub transformerenColonne_new()
Dim x As Worksheet, y As Worksheet
Dim i As Integer, lastrow_x As Integer, lastrow_y As Integer, lastcol_x As Integer
Dim z As Range
Set x = ThisWorkbook.Sheets(1)
Set y = ThisWorkbook.Sheets(2)
Set z = x.UsedRange
FillRange = VBA.Array("sexe", "poste", "voiture")
y.Range("D1:F1").Value = FillRange
lastrow_x = z.Rows.Count
lastcol_x = z.Columns.Count
lastrow_y = y.Range("A1").Rows.Count + 1
For i = 1 To lastrow_x - 1
If x.Cells(i, 1).Value <> 0 Then
y.Range(y.Cells(lastrow_y, 1), y.Cells(lastrow_y + 3, 1)).Value = Application.Transpose(x.Range(x.Cells(1, 1), x.Cells(1, 4)).Value)
y.Range(y.Cells(lastrow_y, 2), y.Cells(lastrow_y + 3, 2)).Value = Application.Transpose(x.Range(x.Cells(i + 1, 1), x.Cells(i + 1, 4)).Value)
y.Range(y.Cells(lastrow_y + 3, 3), y.Cells(lastrow_y + 3, 6)).Value = x.Range(x.Cells(i + 1, 5), x.Cells(i + 1, 8)).Value
lastrow_y = lastrow_y + 4
End If
Next i
y.Columns("A:F").Cells.HorizontalAlignment = xlCenter
End Subou comme ca, comme tu veux
Sub transformerenColonne_new1()
Dim x As Worksheet, y As Worksheet
Dim i As Integer, lastrow_x As Integer, lastrow_y As Integer, lastcol_x As Integer
Dim z As Range
Set x = ThisWorkbook.Sheets(1)
Set y = ThisWorkbook.Sheets(2)
Set z = x.UsedRange
FillRange = VBA.Array("sexe", "poste", "voiture")
y.Range("D1:F1").Value = FillRange
lastrow_x = z.Rows.Count
lastcol_x = z.Columns.Count
lastrow_y = y.Range("A1").Rows.Count + 1
For i = 1 To lastrow_x - 1
If x.Cells(i, 1).Value <> 0 Then
y.Cells(lastrow_y, 1).Value = x.Cells(1, 1).Value
y.Cells(lastrow_y + 1, 1).Value = x.Cells(1, 2).Value
y.Cells(lastrow_y + 2, 1).Value = x.Cells(1, 3).Value
y.Cells(lastrow_y + 3, 1).Value = x.Cells(1, 4).Value
y.Cells(lastrow_y, 2).Value = x.Cells(i + 1, 1).Value
y.Cells(lastrow_y + 1, 2).Value = x.Cells(i + 1, 2).Value
y.Cells(lastrow_y + 2, 2).Value = x.Cells(i + 1, 3).Value
y.Cells(lastrow_y + 3, 2).Value = x.Cells(i + 1, 4).Value
y.Cells(lastrow_y + 3, 3).Value = x.Cells(i + 1, 5).Value
y.Cells(lastrow_y + 3, 4).Value = x.Cells(i + 1, 6).Value
y.Cells(lastrow_y + 3, 5).Value = x.Cells(i + 1, 7).Value
y.Cells(lastrow_y + 3, 6).Value = x.Cells(i + 1, 8).Value
lastrow_y = lastrow_y + 4
End If
Next i
y.Columns("A:F").Cells.HorizontalAlignment = xlCenter
End Sub