Excel VBA fusionner plusieurs colonnes en une seule sur des lignes distinctes

Question

J'ai une feuille de calcul Excel 2007 ouverte avec 5 colonnes et +/- 5000 lignes de données.

Ce que je veux faire est de créer une macro qui:

1. insérer 3 lignes vides sous chaque enregistrement
2. copie la valeur de cette ligne sur la colonne 1 et le coller dans les 3 nouvelles lignes dans colonne 1
3. CUT la valeur de la colonne 3 et le placer dans la première ligne vide au-dessous de la colonne 2
4. CUT la valeur de la colonne 4 et le placer dans la ligne vide au-dessous de la colonne 2
5. CUT la valeur de m colonne 5 et placez-le dans la rangée vide suivante en dessous dans la colonne 2

Je tire mes cheveux en essayant d'accomplir cela mais en vain! s'il vous plaît quelqu'un pourrait-il m'aider avec cela?

Une grande partie grâce

Answer 1

Essayez quelque chose comme ça

Sub Macro1() 
Dim range As range 
Dim i As Integer 

Dim RowCount As Integer 
Dim ColumnCount As Integer 
Dim sheet As worksheet 
Dim tempRange As range 
Dim valueRange As range 
Dim insertRange As range 

    Set range = Selection 
    RowCount = range.Rows.Count 
    ColumnCount = range.Columns.Count 
    For i = 1 To RowCount 
     Set sheet = ActiveSheet 

     Set valueRange = sheet.range("A" & (((i - 1) * 4) + 1), "E" & (((i - 1) * 4) + 1)) 

     Set tempRange = sheet.range("A" & (((i - 1) * 4) + 2), "E" & (((i - 1) * 4) + 2)) 
     tempRange.Select 
     tempRange.Insert xlShiftDown 
     Set insertRange = Selection 
     insertRange.Cells(1, 1) = valueRange.Cells(1, 1) 
     insertRange.Cells(1, 2) = valueRange.Cells(1, 3) 
     valueRange.Cells(1, 3) = "" 

     Set tempRange = sheet.range("A" & (((i - 1) * 4) + 3), "E" & (((i - 1) * 4) + 3)) 
     tempRange.Select 
     tempRange.Insert xlShiftDown 
     Set insertRange = Selection 
     insertRange.Cells(1, 1) = valueRange.Cells(1, 1) 
     insertRange.Cells(1, 2) = valueRange.Cells(1, 4) 
     valueRange.Cells(1, 4) = "" 

     Set tempRange = sheet.range("A" & (((i - 1) * 4) + 4), "E" & (((i - 1) * 4) + 4)) 
     tempRange.Select 
     tempRange.Insert xlShiftDown 
     Set insertRange = Selection 
     insertRange.Cells(1, 1) = valueRange.Cells(1, 1) 
     insertRange.Cells(1, 2) = valueRange.Cells(1, 5) 
     valueRange.Cells(1, 5) = "" 

    Next i 
End Sub 

Answer 2

Que diriez-vous:

Dim cn As Object 
Dim rs As Object 

strFile = Workbooks(1).FullName 
strCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFile _ 
    & ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";" 

Set cn = CreateObject("ADODB.Connection") 
Set rs = CreateObject("ADODB.Recordset") 

cn.Open strCon 

strSQL = "SELECT t.F1, t.Col2 FROM (" _ 
     & "SELECT F1, 1 As Sort, F3 As Col2 FROM [Sheet1$] " _ 
     & "UNION ALL " _ 
     & "SELECT F1, 2 As Sort, F4 As Col2 FROM [Sheet1$] " _ 
     & "UNION ALL " _ 
     & "SELECT F1, 3 As Sort, F5 As Col2 FROM [Sheet1$]) As t " _ 
     & "ORDER BY F1, Sort" 

rs.Open strSQL, cn 

Worksheets("Sheet6").Cells(2, 1).CopyFromRecordset rs 

Answer 3

passe la feuille de calcul à cette fonction particulière. Ce n'est pas une chose compliquée à faire - je serais intéressé de savoir ce qui n'allait pas avec vos approches (il aurait été bon de poster un exemple de code dans votre question).

Public Sub splurge(ByVal sht As Worksheet) 

    Dim rw As Long 
    Dim i As Long 

    For rw = sht.UsedRange.Rows.Count To 1 Step -1 
     With sht 
      Range(.Rows(rw + 1), .Rows(rw + 3)).Insert 
      For i = 1 To 3 
       ' copy column 1 into each new row 
       .Cells(rw, 1).Copy .Cells(rw + i, 1) 
       ' cut column 3,4,5 and paste to col 2 on next rows 
       .Cells(rw, 2 + i).Cut .Cells(rw + i, 2) 
      Next i 
     End With 
    Next rw 

End Sub