求助个列移动问题

onlymir2

表中每列的行数不固定，想根据每列数据行数从小到大的顺序重新排列，拷贝到另一个表中，请各位大侠帮忙！！！

onlymir2

忘记写说明了，sheet1是原始数据，sheet2是想达到的效果

taller

参考代码

1. Sub demo()
   
2.     Dim crr()
   
3.     arr = Sheet1.[a1].CurrentRegion.Value
   
4.     brr = arr
   
5.     ir = UBound(arr, 1)
   
6.     ic = UBound(arr, 2)
   
7.     ReDim crr(1 To ic, 1 To 2)
   
8.     For c = 1 To ic '统计每列行数
   
9.         For r = ir To 1 Step -1
   
10.             If arr(r, c) <> "" Then
    
11.                 crr(c, 1) = c
    
12.                 crr(c, 2) = r
    
13.                 Exit For
    
14.             End If
    
15.         Next
    
16.     Next
    
17.     For i = 1 To ic - 1 '排序
    
18.         For j = i + 1 To ic
    
19.             If crr(i, 2) > crr(j, 2) Then
    
20.                 For k = 1 To 2
    
21.                     tmp = crr(i, k): crr(i, k) = crr(j, k): crr(j, k) = tmp
    
22.                 Next
    
23.             End If
    
24.         Next
    
25.     Next
    
26.     For c = 1 To ic '转换数据
    
27.         For r = 1 To ir
    
28.             brr(r, c) = arr(r, crr(c, 1))
    
29.         Next
    
30.     Next
    
31.     Sheet2.UsedRange.Clear
    
32.     Sheet2.[a1].Resize(ir, ic).Value = brr
    
33. End Sub
    

复制代码

taller

参考示例文件

列自动移动.7z (14.24 KB, 下载次数: 2)

2020-3-16 12:19 上传

点击文件名下载附件

onlymir2

taller 发表于 2020-3-16 12:19
参考示例文件

非常感谢，完美解决问题！！！！

onlymir2

taller 发表于 2020-3-16 12:19
参考示例文件

老师，能把原表格的单元格格式字体不改变的移动过去吗？该怎么修改下代码？

onlymir2

单元格复制用copy命令解决，就是还有合并单元格的咋整呢

taller

参考代码

1. Sub demo()
   
2.     Dim crr()
   
3.     arr = Sheet1.[a1].CurrentRegion.Value
   
4.     ir = UBound(arr, 1)
   
5.     ic = UBound(arr, 2)
   
6.     ReDim crr(1 To ic, 1 To 2)
   
7.     For c = 1 To ic 'í3&#188;&#198;&#195;&#191;áDDDêy
   
8.         For r = ir To 1 Step -1
   
9.             If arr(r, c) <> "" Then
   
10.                 crr(c, 1) = c
    
11.                 crr(c, 2) = r
    
12.                 Exit For
    
13.             End If
    
14.         Next
    
15.     Next
    
16.     For i = 1 To ic - 1 '&#197;&#197;Dò
    
17.         For j = i + 1 To ic
    
18.             If crr(i, 2) > crr(j, 2) Then
    
19.                 For k = 1 To 2
    
20.                     tmp = crr(i, k): crr(i, k) = crr(j, k): crr(j, k) = tmp
    
21.                 Next
    
22.             End If
    
23.         Next
    
24.     Next
    
25.     Sheet2.UsedRange.Clear
    
26.     Sheet2.[a1].Resize(ir, ic).Value = brr
    
27.    
    
28.     For c = 1 To ic '×a&#187;&#187;êy&#190;Y
    
29.         Sheet1.Cells(1, crr(c, 1)).Resize(ir, 1).Copy Sheet2.Cells(1, c)
    
30.     Next
    
31.    
    
32. End Sub
    

复制代码

taller

如果是需要带格式拷贝，其实也不需要将数据读入数组，有其他的方法也可以确定每列的数据个数。

onlymir2

taller 发表于 2020-3-17 07:36
如果是需要带格式拷贝，其实也不需要将数据读入数组，有其他的方法也可以确定每列的数据个数。

是的，我也是用的sheet.cells.copy复制的单元格，后来我又发现我的表格里还有合并单元格的情况，A1和B1合并为A1的，这样复制过去后又出现和原有格式不一样的情况，我也在想确定好每列行数后，排序好然后range拷贝是不是就好了，但是我是初学者，有思路实际代码搞不出来。。。