[已解决]用VBA按要求进行填充

superle!

表1的B列为源。取1进249进制最后60个值处在第几个。首先看1进制，B4319的值是1，D列可以看得出来，1的同值处在B4318的位置。就填充1.第2位是在F列可以看得出来。
如果没有同值的，标记“无”
做个命令按钮在表2黄色背景里填充。

最佳答案

月排行榜 / 总排行榜

suye1010

2013-9-14 22:42

1. Sub SolveTimes()
   
2. Dim d, arr0, arr1(1 To 249, 1 To 60), i, j, k, l
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. arr0 = Sheets("Sheet1").Range("B2:B" & Sheets("Sheet1").Cells(65536, 2).End(xlUp).Row)
   
5. For i = 1 To 249
   
6.     k = 0
   
7.     For j = UBound(arr0) To 1 Step -1
   
8.             If k < 60 Then
   
9.                 k = k + 1
   
10.                 For l = j - i To 1 Step -i
    
11.                     d(arr0(l, 1)) = 1
    
12.                     If d.exists(arr0(j, 1)) Then
    
13.                         arr1(i, k) = d.Count
    
14.                         Exit For
    
15.                     Else
    
16.                         arr1(i, k) = "无"
    
17.                     End If
    
18.                 Next l
    
19.                 d.RemoveAll
    
20.             End If
    
21.     Next j
    
22. Next i
    
23. Sheets("Sheet2").Cells(26, "CD").Resize(249, 60) = arr1
    
24. End Sub
    

复制代码

跳转到最佳答案楼层

上清宫主

有点怀疑自己的汉语能力了，可是……可是只懂汉语呀{:2412:}

我心飞翔410

上清宫主 发表于 2013-9-13 23:06
有点怀疑自己的汉语能力了，可是……可是只懂汉语呀

我发觉他的问题都很绕  要不就很难

superle!

suye1010 发表于 2013-9-14 00:39
arr0 = Sheets("Sheet1").Range("B2:B"&Sheets("Sheet1").cells(65536,2).end(xlup).row)

...

太牛了~！

superle!

1. Sub SolveTimes()
   
2. Dim arr0, arr1(1 To 249, 1 To 60), i, j, k
   
3. arr0 = Sheets("Sheet1").Range("B2:B" & Sheets("Sheet1").Cells(65536, 2).End(xlUp).Row)
   
4. 
   
5. For i = 1 To 249
   
6.     k = 0
   
7.     For j = UBound(arr0) To 1 Step -1
   
8.             If k < 60 Then
   
9.                 k = k + 1
   
10.                 m = 0
    
11.                 For l = j - i To 1 Step -i
    
12.                     m = m + 1
    
13.                     If arr0(j, 1) = arr0(l, 1) Then
    
14.                         arr1(i, k) = m
    
15.                         Exit For
    
16.                     Else
    
17.                         arr1(i, k) = "无"
    
18.                     End If
    
19.                 Next l
    
20.             End If
    
21.     Next j
    
22. Next i
    
23. Sheets("Sheet2").Cells(26, "CD").Resize(249, 60) = arr1
    
24. End Sub

复制代码

完美解决~！

superle!

还是一样的排列。但是中间不管重复多少次，只算1次同值的。

yyyydddd8888

看不太懂你的意思。

suye1010

1. Sub SolveTimes()
   
2. Dim d, arr0, arr1(1 To 249, 1 To 60), i, j, k, l
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. arr0 = Sheets("Sheet1").Range("B2:B" & Sheets("Sheet1").Cells(65536, 2).End(xlUp).Row)
   
5. For i = 1 To 249
   
6.     k = 0
   
7.     For j = UBound(arr0) To 1 Step -1
   
8.             If k < 60 Then
   
9.                 k = k + 1
   
10.                 For l = j - i To 1 Step -i
    
11.                     d(arr0(l, 1)) = 1
    
12.                     If d.exists(arr0(j, 1)) Then
    
13.                         arr1(i, k) = d.Count
    
14.                         Exit For
    
15.                     Else
    
16.                         arr1(i, k) = "无"
    
17.                     End If
    
18.                 Next l
    
19.                 d.RemoveAll
    
20.             End If
    
21.     Next j
    
22. Next i
    
23. Sheets("Sheet2").Cells(26, "CD").Resize(249, 60) = arr1
    
24. End Sub
    

复制代码

superle!

suye1010 发表于 2013-9-14 22:42

太感谢你了。宏代码已经用上了。非常棒~！