[已解决]挑选数组中指定下标号显示数组

yiyaozjk

因为我的数据很都有上万行，所以我想用数组或字典方法实现

具体说，比如：  我将数组区域 工作表的内容当作一个数组区域
    然后：我经过一定计算后，我只想取这个数组中的arr(*,1)、arr(*,2)、arr(*,6)、arr(*,7)列,数组学得不好，不知如何实现？？？？

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2012-12-24 00:31

1. Option Explicit
   
2. 
   
3. '---------------------------------------------------------------------------------------
   
4. ' Procedure : 数据2
   
5. ' Author    : hwc2ycy
   
6. ' Date      : 2012/12/24
   
7. ' Purpose   :
   
8. '---------------------------------------------------------------------------------------
   
9. '
   
10. Sub 数据2()
    
11.     Dim arrCon, iRow%, data, result, rg As Range
    
12.     On Error Resume Next
    
13.     Set rg = Application.InputBox("请用鼠标选择条件区域[N行2列]", , , , , , , 8)
    
14.     If rg.SpecialCells(xlCellTypeConstants, xlNumbers + xlTextValues).Count <> rg.Count Then
    
15.         MsgBox "条件区域有不非文本数值，请重来"
    
16.         Exit Sub
    
17.     End If
    
18.     If rg.Columns.Count <> 2 Then
    
19.         MsgBox "所选的条件区域不是2列，请重来"
    
20.         Exit Sub
    
21.     End If
    
22.     arrCon = rg.Value
    
23.     data = Range("a1").CurrentRegion
    
24.     If UBound(data) <= 2 Then MsgBox "数据不足": Exit Sub
    
25.     Dim i%
    
26.     ReDim result(1 To UBound(arrCon), 1 To UBound(data))
    
27.     For iRow = 1 To UBound(data)
    
28.         For i = 1 To UBound(arrCon)
    
29.             result(i, iRow) = data(iRow, arrCon(i, 2))
    
30.         Next
    
31.     Next
    
32.     With Worksheets("结果")
    
33.         .Range("a1").CurrentRegion = ""
    
34.         .Range("a1").Resize(UBound(data), UBound(arrCon)) = WorksheetFunction.Transpose(result)
    
35.     End With
    
36.     MsgBox "提取完成"
    
37. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

1. Option Explicit
   
2. 
   
3. '---------------------------------------------------------------------------------------
   
4. ' Procedure : 数据
   
5. ' Author    : hwc2ycy
   
6. ' Date      : 2012/12/23
   
7. ' Purpose   :
   
8. '---------------------------------------------------------------------------------------
   
9. '
   
10. Sub 数据()
    
11.     Dim arrCon, iRow%, data, result
    
12.     iRow = Cells(65536, 1).End(xlUp).Row
    
13.     If iRow > 26 Then
    
14.         arrCon = Range("a26:b" & iRow)
    
15.         If UBound(arrCon, 2) <= 1 Then MsgBox "数据不足": Exit Sub
    
16.     Else
    
17.         MsgBox "数据不足"
    
18.         Exit Sub
    
19.     End If
    
20.     data = Range("a1").CurrentRegion
    
21.     Dim i%
    
22.     ReDim result(1 To UBound(arrCon), 1 To UBound(data))
    
23.     For iRow = 1 To UBound(data)
    
24.         For i = 1 To UBound(arrCon)
    
25.             result(i, iRow) = data(iRow, arrCon(i, 2))
    
26.         Next
    
27.     Next
    
28.     With Worksheets("结果")
    
29.         .Range("a1").CurrentRegion = ""
    
30.         .Range("a1").Resize(UBound(data), UBound(arrCon)) = WorksheetFunction.Transpose(result)
    
31.     End With
    
32.     MsgBox "提取完成"
    
33. End Sub

复制代码

hwc2ycy

为避免第2列数据有误，可以在过程内加一句

1. on error resume next

复制代码

hwc2ycy

1. Option Explicit
   
2. 
   
3. '---------------------------------------------------------------------------------------
   
4. ' Procedure : 数据
   
5. ' Author    : hwc2ycy
   
6. ' Date      : 2012/12/23
   
7. ' Purpose   :
   
8. '---------------------------------------------------------------------------------------
   
9. '
   
10. Sub 数据()
    
11.     Dim arrCon, iRow%, data, result
    
12.     On Error Resume Next
    
13.     iRow = Cells(65536, 1).End(xlUp).Row
    
14.     If iRow > 26 Then
    
15.         arrCon = Range("a26:b" & iRow)
    
16.         If UBound(arrCon, 2) <= 1 Then MsgBox "数据不足": Exit Sub
    
17.     Else
    
18.         MsgBox "数据不足"
    
19.         Exit Sub
    
20.     End If
    
21.     data = Range("a1").CurrentRegion
    
22.     If UBound(data) <= 2 Then MsgBox "数据不足": Exit Sub
    
23.     Dim i%
    
24.     ReDim result(1 To UBound(arrCon), 1 To UBound(data))
    
25.     For iRow = 1 To UBound(data)
    
26.         For i = 1 To UBound(arrCon)
    
27.             result(i, iRow) = data(iRow, arrCon(i, 2))
    
28.         Next
    
29.     Next
    
30.     With Worksheets("结果")
    
31.         .Range("a1").CurrentRegion = ""
    
32.         .Range("a1").Resize(UBound(data), UBound(arrCon)) = WorksheetFunction.Transpose(result)
    
33.     End With
    
34.     MsgBox "提取完成"
    
35. End Sub

复制代码

hwc2ycy

1. Option Explicit
   
2. 
   
3. '---------------------------------------------------------------------------------------
   
4. ' Procedure : 数据2
   
5. ' Author    : hwc2ycy
   
6. ' Date      : 2012/12/24
   
7. ' Purpose   :
   
8. '---------------------------------------------------------------------------------------
   
9. '
   
10. Sub 数据2()
    
11.     Dim arrCon, iRow%, data, result, rg As Range
    
12.     On Error Resume Next
    
13.     Set rg = Application.InputBox("请用鼠标选择条件区域[N行2列]", , , , , , , 8)
    
14.     If rg.SpecialCells(xlCellTypeConstants, xlNumbers + xlTextValues).Count <> rg.Count Then
    
15.         MsgBox "条件区域有不非文本数值，请重来"
    
16.         Exit Sub
    
17.     End If
    
18.     If rg.Columns.Count <> 2 Then
    
19.         MsgBox "所选的条件区域不是2列，请重来"
    
20.         Exit Sub
    
21.     End If
    
22.     arrCon = rg.Value
    
23.     data = Range("a1").CurrentRegion
    
24.     If UBound(data) <= 2 Then MsgBox "数据不足": Exit Sub
    
25.     Dim i%
    
26.     ReDim result(1 To UBound(arrCon), 1 To UBound(data))
    
27.     For iRow = 1 To UBound(data)
    
28.         For i = 1 To UBound(arrCon)
    
29.             result(i, iRow) = data(iRow, arrCon(i, 2))
    
30.         Next
    
31.     Next
    
32.     With Worksheets("结果")
    
33.         .Range("a1").CurrentRegion = ""
    
34.         .Range("a1").Resize(UBound(data), UBound(arrCon)) = WorksheetFunction.Transpose(result)
    
35.     End With
    
36.     MsgBox "提取完成"
    
37. End Sub

复制代码

hwc2ycy

5楼的方法，要求条件区只能是常量的文本和数字。如果用MATCH公式来返回所在列，则代码无法运行。