スプリットごとに5列

Question

私は1つのExcelの表にこれらの列があります。

1,2,3,4,5,6,7,8,9,10... 
1a,2a,3a,4a,5a,6a,7a,8a,9a,10a... 
... 

と私は別のものにこれらの列をコピーするには、ファイルとスプリットを得意と別の行

1,2,3,4,5 
6,7,8,9,10 
1a,2a,3a,4a,5a 
6a,7a,8a,9a,10a 

にすべての5番目の列を

Answer 1

私は、分離したいデータが最初の行にだけあると仮定しています。その場合は、以下を参考にすべきである：

Sub columnsInRows() 

     Dim rngData As Range 
     Dim intDelimiter As Integer 
     Dim arrRows As Variant 
     Dim cell As Range 
     Dim counter As Integer 
     Dim row As Integer 


     row = 1 
     intDelimiter = 5 

     Worksheets("Table1").Activate 

     Set rngData = Worksheets("Table1").UsedRange 

     ReDim arrRows(rngData.Cells.Count - 1) 

     For Each cell In rngData.Rows.Cells 
      arrRows(counter) = cell.Value 
      counter = counter + 1 
     Next 

     Worksheets("Table2").Activate 

     For counter = 0 To UBound(arrRows) 
      Cells(row, counter Mod intDelimiter + 1).Value = arrRows(counter) 
       If (counter + 1) Mod intDelimiter = 0 Then 
        row = row + 1 
       End If 
     Next 
     Worksheets("Table2").UsedRange.NumberFormat = "#,##0.00" 

    End Sub 

Answer 2

これがすべてを行います：非常に迅速に

Sub evyfifth() 
    Dim ws As Worksheet 
    Dim ows as Worksheet 
    Dim rngarr() As Variant 
    Dim oarr() As Variant 
    Dim lastclm As Long 
    Dim lastrw As Long 
    Dim i&, j&, x&, y&, clms& 

    clms = 5 

    Set ws = Sheets("Sheet16") 'Change to the sheet of data 
    Set ows = Sheets("Sheet17") ' Change to output sheet 

    With ws 
     lastclm = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column 
     lastrw = .Cells.Find("*", , , , xlByRows, xlPrevious).Row 
     rngarr = .Range(.Cells(1, 1), .Cells(lastrw, lastclm)).Value 
     ReDim oarr(1 To Application.RoundUp(lastrw * (lastclm/clms), 0), 1 To clms) 
     x = 1 
     For i = 1 To UBound(rngarr, 1) 
      y = 1 
      For j = 1 To UBound(rngarr, 2) 
       If y < clms Then 
        oarr(x, y) = rngarr(i, j) 
        y = y + 1 
       Else 
        oarr(x, y) = rngarr(i, j) 
        y = 1 
        x = x + 1 
       End If 
      Next j 
     Next i 

    End With 
    ows.Range("A1").Resize(UBound(oarr, 1), clms).Value = oarr 



End Sub 

とします。