二维转一维

lenghonghai601

1. 这样试试，不知道你要达到的是不是这个意思。
   
2. Sub 按钮1_Click()
   
3. Dim arr, brr(), m%, i%, j%
   
4. arr = Range("a1").CurrentRegion
   
5. For i = 2 To UBound(arr)
   
6.     For j = 4 To UBound(arr, 2)
   
7.         If Cells(i, j) <> "" Then
   
8.             m = m + 1
   
9.             ReDim Preserve brr(1 To 4, 1 To m)
   
10.             brr(1, m) = arr(i, 1): brr(2, m) = arr(i, 2): brr(3, m) = arr(i, 3): brr(4, m) = arr(i, j)
    
11.         End If
    
12.     Next j
    
13. Next i
    
14. Range("a14").Resize(m, 4) = WorksheetFunction.Transpose(brr)
    
15. End Sub

复制代码

550975855

lenghonghai601 发表于 2018-6-20 16:02
这是附件，请测试。

请看附件这个是我的附件

lenghonghai601

550975855 发表于 2018-6-20 16:26
请看附件这个是我的附件

附件有隐藏列，不知道什么意思？最好是模拟下你的结果。

一把小刀闯天下

'猜一个

Option Explicit

Sub test()
  Dim arr, i, j, k, n
  arr = [a1].CurrentRegion
  ReDim brr(1 To 10 ^ 4, 1 To 31)
  For i = 2 To UBound(arr, 1)
    For j = 4 To UBound(arr, 2)
      If Len(arr(i, j)) > 0 Then
        n = n + 1
        For k = 1 To 3: brr(n, k) = arr(i, k): Next
        brr(n, k) = arr(1, j): brr(n, UBound(brr, 2)) = arr(i, j)
      End If
  Next j, i
  With [a14]
    .Resize(10 ^ 4, UBound(brr, 2)).ClearContents
    If n > 0 Then .Resize(n, UBound(brr, 2)) = brr
  End With
End Sub