[已解决]请求完善代码,让数组一次i循环得出结果

xdwy81129

题意是：
B2开始往下（B列内）与f列的多个数据对比，如果其中1个相同，记录同行的c列为结果

最后按照f列的多个数据横向列示结果。

问题的关键在：
1.只能从B2一次开始在B列网下找相同的数据，一直找到B列的最后一个单元格，所要的结果就已经出来，而不是可以让B2多次开始向下对比数据
2.需要数组完成。
3.结果不可以用先定义一个很大的数组来装入结果，需要找到一个相同，扩大一个数组来装找到的接口


就像通过本例学习如下知识
1.B列只循环一次就可以完成多个结果的对比得到结果（因为只循环一次，所以速度可以更快）
2.怎么扩大未知结果的数组

最后请大虾们一定帮助赐教









数组一次i循环解决.rar (51.46 KB, 下载次数: 27)

2011-1-20 23:25 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

吕?布

2011-1-21 08:45

1. 
   
2. 
   
3. Sub 布Demo()
   
4.     Dim arrCer As Variant
   
5.     Dim arrData As Variant
   
6.     Dim arrResult() As String
   
7.     Dim arrDataCounts() As Long
   
8.     Dim lMaxDataCounts As Long
   
9.     Dim i As Long, j As Long
   
10.     ' 读取数据
    
11.     arrCer = Range("F1:F27")
    
12.     arrData = Range("B3:C4000")
    
13.     ' 初始化数组
    
14.     ReDim arrDataCounts(LBound(arrCer, 1) To UBound(arrCer, 1))
    
15.     ReDim arrResult(LBound(arrCer, 1) To UBound(arrCer, 1), 1 To 1)
    
16.     ' 算出结果
    
17.     For i = LBound(arrData, 1) To UBound(arrData, 1)
    
18.         For j = LBound(arrCer, 1) To UBound(arrCer, 1)
    
19.             If arrData(i, 1) = arrCer(j, 1) Then
    
20.                 ' 列数据计数累加1
    
21.                 arrDataCounts(j) = arrDataCounts(j) + 1
    
22.                 ' 必要时扩展结果数组
    
23.                 If lMaxDataCounts < arrDataCounts(j) Then
    
24.                     lMaxDataCounts = arrDataCounts(j)
    
25.                     ReDim Preserve arrResult(LBound(arrResult, 1) To UBound(arrResult, 1), 1 To lMaxDataCounts)
    
26.                 End If
    
27.                 ' C列数据写入结果数组
    
28.                 arrResult(j, arrDataCounts(j)) = arrData(i, 2)
    
29.             End If
    
30.         Next j
    
31.     Next i
    
32.     ' 写结果
    
33.     Range("H3").Resize(UBound(arrResult, 2), UBound(arrResult, 1)) = Application.WorksheetFunction.Transpose(arrResult)
    
34. End Sub
    
35. 
    

复制代码

跳转到最佳答案楼层

无聊的疯子

回复 xdwy81129 的帖子

说实在的没怎么看明白你的表,如果时你是想在指定区域中去查找找最后一个符合条件的单元格的话,可以用以下代码

Set C = .Range("A1:A1000").Find(.Cells(H, 1), lookat:=xlWhole, SearchDirection:=xlPrevious)

.Range("A1:A1000").Find=到指定区域A1:A1000中去查找值  .Cells(H, 1)

lookat:=xlWhole   =完全匹配

SearchDirection:=xlPrevious  =从A1开始倒查 也就是从A1000查到A1

如果不要此参数 就是从A1开始往下查...(也就是从A1开始查到A1000)

具体用法你可以查找帮助  Range.Find  

无聊的疯子

这个我没办法...

我也学习一下吧!!期待高手的答案

amulee

结果是啥？

amulee

像在闯关，限制条件太多，速度未必快多少
是这样？

1. Sub sadssss()
   
2.     Dim arrYS
   
3.     Dim arrTJ
   
4.     Dim StrTJ
   
5.     Dim arrJG
   
6.     arrTJ = WorksheetFunction.Transpose(Range("F1:F27").Value)
   
7.     arrYS = Range("b3:c" & [b65536].End(3).Row)
   
8.     ReDim arrJG(1 To UBound(arrTJ))
   
9.     StrTJ = Join(arrTJ, ",")
   
10.     For i = 1 To UBound(arrYS)
    
11.         j = InStr(StrTJ, arrYS(i, 1))
    
12.         If j > 0 Then
    
13.             j = (j - 1) / 4 + 1
    
14.             If arrJG(j) = "" Then
    
15.                 arrJG(j) = arrYS(i, 2)
    
16.             Else
    
17.                 arrJG(j) = arrJG(j) & "," & arrYS(i, 2)
    
18.             End If
    
19.         End If
    
20.     Next i
    
21.     For j = 1 To UBound(arrJG)
    
22.         arrTJ = Split(arrJG(j), ",")
    
23.         Cells(3, j + 7).Resize(UBound(arrTJ) + 1, 1) = WorksheetFunction.Transpose(arrTJ)
    
24.     Next j
    
25. End Sub

复制代码

吕?布

1. 
   
2. 
   
3. Sub 布Demo()
   
4.     Dim arrCer As Variant
   
5.     Dim arrData As Variant
   
6.     Dim arrResult() As String
   
7.     Dim arrDataCounts() As Long
   
8.     Dim lMaxDataCounts As Long
   
9.     Dim i As Long, j As Long
   
10.     ' 读取数据
    
11.     arrCer = Range("F1:F27")
    
12.     arrData = Range("B3:C4000")
    
13.     ' 初始化数组
    
14.     ReDim arrDataCounts(LBound(arrCer, 1) To UBound(arrCer, 1))
    
15.     ReDim arrResult(LBound(arrCer, 1) To UBound(arrCer, 1), 1 To 1)
    
16.     ' 算出结果
    
17.     For i = LBound(arrData, 1) To UBound(arrData, 1)
    
18.         For j = LBound(arrCer, 1) To UBound(arrCer, 1)
    
19.             If arrData(i, 1) = arrCer(j, 1) Then
    
20.                 ' 列数据计数累加1
    
21.                 arrDataCounts(j) = arrDataCounts(j) + 1
    
22.                 ' 必要时扩展结果数组
    
23.                 If lMaxDataCounts < arrDataCounts(j) Then
    
24.                     lMaxDataCounts = arrDataCounts(j)
    
25.                     ReDim Preserve arrResult(LBound(arrResult, 1) To UBound(arrResult, 1), 1 To lMaxDataCounts)
    
26.                 End If
    
27.                 ' C列数据写入结果数组
    
28.                 arrResult(j, arrDataCounts(j)) = arrData(i, 2)
    
29.             End If
    
30.         Next j
    
31.     Next i
    
32.     ' 写结果
    
33.     Range("H3").Resize(UBound(arrResult, 2), UBound(arrResult, 1)) = Application.WorksheetFunction.Transpose(arrResult)
    
34. End Sub
    
35. 
    

复制代码

老糊涂

学习高手的代码

吕?布

传个附件上来

sunjing-zxl

学习战神！！！

xdwy81129

回复 amulee 的帖子

第一个循环增加一句：
    If arrjg(j) = "" Then arrjg(j) = ","

第二个循环增加一句：
If Left(arrjg(j), 1) = "," Then arrjg(j) = Mid(arrjg(j), 2, Len(arrjg(j)))

补丁消灭掉了

再次向阿木老师指教其他思维方式解答问题表示感谢