求助，如何把列合并用VBA实现，谢谢各位

spxzheng123

如附件中，有表一和表二
表一数据如下（有N列这样的数据）：

编号	流程	数量	编号	流程	数量	编号	流程	数量	编号	流程	数量
AAA1	aaa1	45435	AAA2	aaa2	4425	AAA3	aaa3	4425
BBB1	bbb1	4554	BBB2	bbb2	878	BBB3	bbb3	878
CCC1	ccc1	45435	CCC2	ccc2	878	CCC3	ccc3	878

如何用vba实现合并到表二的格式：

编号	流程	数量
AAA1	aaa1	45435
BBB1	bbb1	4554
CCC1	ccc1	45435
AAA2	aaa2	4425
BBB2	bbb2	878
CCC2	ccc2	878
AAA3	aaa3	4425
BBB3	bbb3	878
CCC3	ccc3	878

谢谢各位大神指点

一把小刀闯天下

Option Explicit

Sub test()
  Dim arr, i, j, k, m
  arr = Sheets("表一").[a1].CurrentRegion.Offset(1)
  If UBound(arr, 2) Mod 3 > 0 Then MsgBox "!": Exit Sub
  ReDim brr(1 To (UBound(arr, 2) \ 3) * (UBound(arr, 1) - 1), 1 To 3) As String
  Debug.Print UBound(brr, 1)
  For j = 1 To UBound(arr, 2) Step 3
    For i = 1 To UBound(arr, 1) - 1
      m = m + 1
      For k = j To j + 2: brr(m, k - j + 1) = arr(i, k): Next
  Next i, j
  With Sheets("表二").[a1]
    .Resize(, 3) = Split("流程 数量 标号")
    .Offset(1).Resize(m, 3) = brr
  End With
End Sub

约定的童话

一把小刀闯天下 发表于 2018-9-25 12:09
Option Explicit

Sub test()

刀哥出马，寸草不生....哈哈

spxzheng123

一把小刀闯天下 发表于 2018-9-25 12:09
Option Explicit

Sub test()

十分感谢你的回复

约定的童话

spxzheng123 发表于 2018-9-25 13:06
十分感谢你的回复

感觉有帮主的话，右下角评分一下

wjcmouse

1. Sub test()
   
2.     Dim sht1 As Worksheet, sht2 As Worksheet, arr, i%, j%, n%, k%
   
3.    
   
4.     Set sht1 = Worksheets("表一")
   
5.     Set sht2 = Worksheets("表二")
   
6.     arr = sht1.UsedRange
   
7.     n = sht1.[a1].End(xlToRight).Column
   
8.     k = UBound(arr)
   
9.    
   
10.     For j = 1 To n
    
11.         For i = 2 To k
    
12.             If arr(1, j) = "编号" Then
    
13.                 sht2.[a5000].End(xlUp).Offset(1, 0) = arr(i, j)
    
14.             ElseIf arr(1, j) = "流程" Then
    
15.                 sht2.[b5000].End(xlUp).Offset(1, 0) = arr(i, j)
    
16.             ElseIf arr(1, j) = "数量" Then
    
17.                 sht2.[c5000].End(xlUp).Offset(1, 0) = arr(i, j)
    
18.             End If
    
19.         Next
    
20.     Next
    
21.    
    
22. End Sub
    

复制代码