[已解决]多列数据区域转换成一列

luchao124

多列数据区域转换成一列

F1:J4是数据局域  转换的结果是A1：A20

Sub rangetoonecol()
Dim TheRng, TempArr
Dim i As Integer, j As Integer, elemCount As Integer
On Error GoTo line1
Range("a:a").ClearContents
If Selection.Cells.Count = 1 Then
  Range("a1") = Selection
Else
  TheRng = Selection
  elemCount = UBound(TheRng, 1) * UBound(TheRng, 2)
  ReDim TempArr(1 To elemCount, 1 To 1)
  For i = 1 To UBound(TheRng, 1)
    For j = 1 To UBound(TheRng, 2)
      TempArr((i - 1) * UBound(TheRng, 2) + j, 1) = TheRng(i, j)
    Next
  Next
  Range("a1:a" & elemCount) = TempArr
End If
line1:
End Sub


以上代码可以实现图中效果，但是它是必须先选择数据区域，然后执行代码后直接转换到A列   
我现在的要求效果是，不用先选择数据区域 直接执行代码后，弹出提示框 选择需要转换的数据区域，然后再弹出提示框，选择存放区域起始单元格。
请大神实现代码 谢谢！

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2017-5-25 16:47

1. Sub rangetoonecol()
   
2. Dim TheRng, TempArr, rng As Range
   
3. Dim i As Integer, j As Integer, elemCount As Integer
   
4. On Error GoTo line1
   
5. Range("a:a").ClearContents
   
6. Set rng = Application.InputBox("", , , , , , , 8)
   
7. If rng.Cells.Count = 1 Then
   
8.   Range("a1") = rng
   
9. Else
   
10.   TheRng = rng
    
11.   elemCount = UBound(TheRng, 1) * UBound(TheRng, 2)
    
12.   ReDim TempArr(1 To elemCount, 1 To 1)
    
13.   For i = 1 To UBound(TheRng, 1)
    
14.     For j = 1 To UBound(TheRng, 2)
    
15.       TempArr((i - 1) * UBound(TheRng, 2) + j, 1) = TheRng(i, j)
    
16.     Next
    
17.   Next
    
18.   Range("a1:a" & elemCount) = TempArr
    
19. End If
    
20. line1:
    
21. End Sub

复制代码

跳转到最佳答案楼层

大灰狼1976

1. Sub rangetoonecol()
   
2. Dim TheRng, TempArr, rng As Range
   
3. Dim i As Integer, j As Integer, elemCount As Integer
   
4. On Error GoTo line1
   
5. Range("a:a").ClearContents
   
6. Set rng = Application.InputBox("", , , , , , , 8)
   
7. If rng.Cells.Count = 1 Then
   
8.   Range("a1") = rng
   
9. Else
   
10.   TheRng = rng
    
11.   elemCount = UBound(TheRng, 1) * UBound(TheRng, 2)
    
12.   ReDim TempArr(1 To elemCount, 1 To 1)
    
13.   For i = 1 To UBound(TheRng, 1)
    
14.     For j = 1 To UBound(TheRng, 2)
    
15.       TempArr((i - 1) * UBound(TheRng, 2) + j, 1) = TheRng(i, j)
    
16.     Next
    
17.   Next
    
18.   Range("a1:a" & elemCount) = TempArr
    
19. End If
    
20. line1:
    
21. End Sub

复制代码

luchao124

大灰狼1976 发表于 2017-5-25 16:47

谢谢你的热心回答。实现了选择需要转换的数据区域。我又在此基础上修改了一下  又实现了选择存放区域起始单元格。

1. Sub rangetoonecol2()
   
2. Dim TheRng, TempArr, RNG As Range
   
3. Dim i As Integer, j As Integer, elemCount As Integer
   
4. On Error Resume Next
   
5. Set RNG = Application.InputBox("请选择源区域", "区域转一列", , , , , , 8)
   
6. If RNG.Cells.Count = 1 Then
   
7.     MsgBox "所选择区域单元格个数应该大于1"
   
8.     Exit Sub
   
9. Else
   
10.   TheRng = RNG
    
11.   elemCount = UBound(TheRng, 1) * UBound(TheRng, 2)
    
12.   ReDim TempArr(1 To elemCount, 1 To 1)
    
13.   For i = 1 To UBound(TheRng, 1)
    
14.     For j = 1 To UBound(TheRng, 2)
    
15.       TempArr((i - 1) * UBound(TheRng, 2) + j, 1) = TheRng(i, j)
    
16.     Next
    
17.   Next
    
18. Set RNG = Application.InputBox("请选择存放区域起始单元格", "区域转一列", , , , , , 8)
    
19.   RNG(1).Resize(elemCount, 1) = TempArr
    
20. End If
    
21. End Sub

复制代码

大灰狼1976

能够举一反三，在学习中成长，是极好的。