Hsieh

回復 1# lyc43210
試試看

1. Sub ex()
   
2. Dim Ar() As String, i&, t$, s&
   
3. For i = 1 To [A1].End(xlDown).Row Step 2
   
4.   t = Trim(Cells(i, 1)) & Cells(i + 1, 1)
   
5.    ReDim Preserve Ar(s)
   
6.    Ar(s) = t
   
7.    s = s + 1
   
8. Next
   
9. [B1].Resize(s, 1) = Application.Transpose(Ar)
   
10. End Sub

複製代碼

Hsieh

回復 7# lyc43210
陣列速度會好些

1. Sub ex()
   
2. Dim ar()
   
3. x = 6 '指定整理後欄數
   
4. With ActiveSheet
   
5. Set Rng = .Columns("A:H").SpecialCells(xlCellTypeConstants)
   
6. k = Application.CountA(Rng)
   
7. s = Int(k / x) + IIf(k > Int(k / x) * x, 1, 0) '計算陣列列數
   
8. ReDim ar(s, 1 To x) '宣告陣列
   
9. For Each a In Rng
   
10. i = i + 1
    
11. r = Int((i - 1) / x)
    
12. j = i - r * x
    
13.    ar(r, j) = a.Value '陣列賦值
    
14. Next
    
15. .Columns("A:H") = "" '清空原資料
    
16. .[A1].Resize(r + 1, x) = ar '寫入陣列
    
17. End With
    
18. End Sub

複製代碼