我有一個excel表格這些列:斯普利特每5列到另一行
1,2,3,4,5,6,7,8,9,10...
1a,2a,3a,4a,5a,6a,7a,8a,9a,10a...
...
,我想這些列複製到另一個Excel文件,並每5列拆分到其他行
1,2,3,4,5
6,7,8,9,10
1a,2a,3a,4a,5a
6a,7a,8a,9a,10a
我有一個excel表格這些列:斯普利特每5列到另一行
1,2,3,4,5,6,7,8,9,10...
1a,2a,3a,4a,5a,6a,7a,8a,9a,10a...
...
,我想這些列複製到另一個Excel文件,並每5列拆分到其他行
1,2,3,4,5
6,7,8,9,10
1a,2a,3a,4a,5a
6a,7a,8a,9a,10a
我假設你想分開的數據只位於第一行。如果是這樣的情況下,下面應該是有幫助的:
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
這將做這一切:
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
而且速度非常快。
太棒了...非常感謝你 – Peter
你試過了什麼代碼?用它更新問題,所以我們可以幫你 –