[已解决]请教数组提取问题

yizhih

请教数组提取问题,谢谢！
请教数组提取问题.rar (111.21 KB, 下载次数: 24)

2013-1-26 18:24 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-1-26 21:24

1. Sub 提取1()
   
2.     Dim ShtArr, arr(1 To 6, 1 To 1)
   
3.     Dim iRow&, i&, j&, k&, iRow2&, iCol&
   
4.     Dim shtMerge1$, DestShtArr
   
5.     Dim shtPos&
   
6.     shtMerge1 = "合并1"
   
7.     ShtArr = Array("主表格", "主表格1", "主表格2", "主表格3", "主表格4", "主表格5")
   
8.     DestShtArr = Array("合并", "合并1", "合并2", "合并3", "合并4")
   
9.     Application.ScreenUpdating = False
   
10.    
    
11.     With Worksheets(ShtArr(0))
    
12.         iRow = .Cells(Rows.Count, "au").End(xlUp).Row
    
13.         iCol = .Cells(16, Columns.Count).End(xlToLeft).Column
    
14.     End With
    
15. 
    
16.     For k = 47 To 55 Step 2
    
17.         Worksheets(DestShtArr(shtPos)).Columns("j").Clear
    
18.         For i = 16 To iRow
    
19.             'Erase arr
    
20.             For j = 0 To UBound(ShtArr)
    
21.                 arr(j + 1, 1) = Worksheets(ShtArr(j)).Cells(i, k)
    
22.                 If Len(arr(j + 1, 1)) = 0 Then arr(j + 1, 1) = " "
    
23.             Next j
    
24.             
    
25.             With Worksheets(DestShtArr(shtPos))
    
26.                 iRow2 = .Cells(Rows.Count, "j").End(xlUp).Row + 1
    
27.                 If iRow2 < 6 Then iRow2 = 6
    
28.                 .Cells(iRow2, "j").Resize(5) = arr
    
29.                 .Columns("j").AutoFit
    
30.                 .Columns("j").HorizontalAlignment = xlLeft
    
31.             End With
    
32.         Next i
    
33.         shtPos = shtPos + 1
    
34.     Next k
    
35.     Application.ScreenUpdating = True
    
36.     MsgBox "提取完成"
    
37. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

1. Sub 提取1()
   
2.     Dim ShtArr, arr(1 To 5, 1 To 1)
   
3.     Dim iRow&, i&, j&, k&, iRow2&, iCol&
   
4.     Dim shtMerge1$
   
5.     shtMerge1 = "合并1"
   
6.     ShtArr = Array("主表格", "主表格1", "主表格2", "主表格3", "主表格4", "主表格5")
   
7.     Application.ScreenUpdating = False
   
8.     With Worksheets(ShtArr(0))
   
9.         iRow = .Cells(Rows.Count, "au").End(xlUp).Row
   
10.         iCol = .Cells(16, Columns.Count).End(xlToLeft).Column
    
11.     End With
    
12.    
    
13.     For k = 47 To 55 Step 2
    
14.         Worksheets(shtMerge1).Columns(k).Clear
    
15.         For i = 16 To iRow
    
16.             Erase arr
    
17.             For j = 0 To UBound(ShtArr) - 1
    
18.                 arr(j + 1, 1) = Worksheets(ShtArr(j)).Cells(i, k)
    
19.             Next j
    
20.             'Stop
    
21.             With Worksheets(shtMerge1)
    
22.                 iRow2 = .Cells(Rows.Count, k).End(xlUp).Row + 1
    
23.                 If iRow2 < 16 Then iRow2 = 16
    
24.                 .Cells(iRow2, k).Resize(5) = arr
    
25.             End With
    
26.         Next i
    
27.         Worksheets(shtMerge1).Columns(k).AutoFit
    
28.         Worksheets(shtMerge1).Columns(k).HorizontalAlignment = xlLeft
    
29.     Next k
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "提取完成"
    
32. End Sub

复制代码

hwc2ycy

如果要想实现数据列扩充，就必须把第主表格第16行相对应的列内容不能为空。

hwc2ycy

1. Sub 提取2()
   
2.     Dim shtHz$
   
3.     Dim iRow&
   
4.     Dim arr, arr2()
   
5.     Dim i&, j&, k&, iRow2&
   
6.     With Worksheets("合并")
   
7.         iRow = .Cells(Rows.Count, "j").End(xlUp).Row
   
8.         If iRow < 6 Then Exit Sub
   
9.         arr = .Range("j6:j" & iRow)
   
10.     End With
    
11.     ReDim arr2(1 To UBound(arr) * 6, 1 To 1)
    
12.     iRow = UBound(arr)
    
13.     For i = 1 To UBound(arr)
    
14.         For j = 1 To 6
    
15.             iRow2 = i + j * 6 - 6
    
16.             If iRow2 > iRow Then Exit For
    
17.             k = k + 1
    
18.             arr2(k, 1) = arr(iRow2, 1)
    
19.         Next
    
20.     Next
    
21.     With Worksheets("汇总")
    
22.         .Range("j:j").ClearContents
    
23.         .Range("j6").Resize(k) = arr2
    
24.     End With
    
25.     MsgBox "提取完成"
    
26. End Sub

复制代码

yizhih

hwc2ycy 发表于 2013-1-26 19:40

首先谢谢 hwc2ycy 老师。
1、提取1没有提取出数据，不知道提取到哪里了
2、提取2：J6：J41是第一组，第一组提取完后就不要在提取了，然后是第二组J42：J77，第二组提取完后就不要在提取了，然后是第三组J78：J113，第三组提取完后就不要在提取了，然后是第四组..........，
      提取2的错误是在一个组里循环提取了。

hwc2ycy

1.提取1提取到 合并1工作表 里了。
2.那也是是汇总表误导人了。

hwc2ycy

提取1的数据放到合并的AU列去了，题目意思看错了，

yizhih

hwc2ycy 发表于 2013-1-26 20:58
1.提取1提取到 合并1工作表 里了。
2.那也是是汇总表误导人了。

提取1

hwc2ycy

1. Sub 提取1()
   
2.     Dim ShtArr, arr(1 To 6, 1 To 1)
   
3.     Dim iRow&, i&, j&, k&, iRow2&, iCol&
   
4.     Dim shtMerge1$, DestShtArr
   
5.     Dim shtPos&
   
6.     shtMerge1 = "合并1"
   
7.     ShtArr = Array("主表格", "主表格1", "主表格2", "主表格3", "主表格4", "主表格5")
   
8.     DestShtArr = Array("合并", "合并1", "合并2", "合并3", "合并4")
   
9.     Application.ScreenUpdating = False
   
10.    
    
11.     With Worksheets(ShtArr(0))
    
12.         iRow = .Cells(Rows.Count, "au").End(xlUp).Row
    
13.         iCol = .Cells(16, Columns.Count).End(xlToLeft).Column
    
14.     End With
    
15. 
    
16.     For k = 47 To 55 Step 2
    
17.         Worksheets(DestShtArr(shtPos)).Columns("j").Clear
    
18.         For i = 16 To iRow
    
19.             'Erase arr
    
20.             For j = 0 To UBound(ShtArr)
    
21.                 arr(j + 1, 1) = Worksheets(ShtArr(j)).Cells(i, k)
    
22.                 If Len(arr(j + 1, 1)) = 0 Then arr(j + 1, 1) = " "
    
23.             Next j
    
24.             
    
25.             With Worksheets(DestShtArr(shtPos))
    
26.                 iRow2 = .Cells(Rows.Count, "j").End(xlUp).Row + 1
    
27.                 If iRow2 < 6 Then iRow2 = 6
    
28.                 .Cells(iRow2, "j").Resize(5) = arr
    
29.                 .Columns("j").AutoFit
    
30.                 .Columns("j").HorizontalAlignment = xlLeft
    
31.             End With
    
32.         Next i
    
33.         shtPos = shtPos + 1
    
34.     Next k
    
35.     Application.ScreenUpdating = True
    
36.     MsgBox "提取完成"
    
37. End Sub

复制代码

hwc2ycy

代码刚刚重新又改了，如果你用的话，最好重新复制一次。
2个小地方没注意到。
合并表跟你的结果图是差不多的了，校验的事就交你了。