[已解决]VBA查找行、列坐标并填入相应数量

PC8888

快过春节了，心里还有件事一直未了心愿。请求高手帮助写个VBA代码。具体见图片和附件

最佳答案

月排行榜 / 总排行榜

雪舞子

2016-2-2 20:39

了却你的心愿，好好过个春节吧。

1. Sub test()
   
2.     Dim d As Object, arr, i&, j&
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Range("l4:m30")
   
5.     For i = 1 To UBound(arr)
   
6.         If Len(arr(i, 1)) Then
   
7.             d(arr(i, 1)) = arr(i, 2)
   
8.         End If
   
9.     Next
   
10.     For i = 3 To [a65536].End(3).Row
    
11.         For j = 2 To [iv2].End(1).Column
    
12.             s = Cells(i, 1) & "/" & Cells(2, j)
    
13.             If d.exists(s) Then
    
14.                 Cells(i, j) = d(s)
    
15.             End If
    
16.         Next
    
17.     Next
    
18. End Sub

复制代码

111.rar (18.65 KB, 下载次数: 20)

2016-2-2 20:38 上传

点击文件名下载附件

跳转到最佳答案楼层

雪舞子

了却你的心愿，好好过个春节吧。

1. Sub test()
   
2.     Dim d As Object, arr, i&, j&
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Range("l4:m30")
   
5.     For i = 1 To UBound(arr)
   
6.         If Len(arr(i, 1)) Then
   
7.             d(arr(i, 1)) = arr(i, 2)
   
8.         End If
   
9.     Next
   
10.     For i = 3 To [a65536].End(3).Row
    
11.         For j = 2 To [iv2].End(1).Column
    
12.             s = Cells(i, 1) & "/" & Cells(2, j)
    
13.             If d.exists(s) Then
    
14.                 Cells(i, j) = d(s)
    
15.             End If
    
16.         Next
    
17.     Next
    
18. End Sub

复制代码

111.rar (18.65 KB, 下载次数: 20)

2016-2-2 20:38 上传

点击文件名下载附件

PC8888

雪舞子 发表于 2016-2-2 20:39
了却你的心愿，好好过个春节吧。

太完美了，谢谢！祝春节快乐，合家幸福！

grf1973

1. Sub grf()
   
2.     Set d = CreateObject("scripting.dictionary")       '行
   
3.     Set d1 = CreateObject("scripting.dictionary")     '列
   
4.     [b3:j100].ClearContents
   
5.     arr = [a1].CurrentRegion  '表一
   
6.     For i = 3 To UBound(arr)
   
7.         d(Val(arr(i, 1))) = i
   
8.     Next
   
9.     For j = 2 To UBound(arr, 2)
   
10.         d1(Val(arr(2, j))) = j
    
11.     Next
    
12.     brr = Range("m4:n" & [m65536].End(3).Row)
    
13.     For k = 1 To UBound(brr)
    
14.         x = brr(k, 1)
    
15.         If InStr(x, "/") > 0 Then
    
16.             a = Val(Split(x, "/")(0)): i = d(a)
    
17.             b = Val(Split(x, "/")(1)): j = d1(b)
    
18.             If i * j > 0 Then arr(i, j) = brr(k, 2)
    
19.         End If
    
20.     Next
    
21.     [a1].Resize(UBound(arr), UBound(arr, 2)) = arr
    
22. End Sub
    

复制代码

PC8888

grf1973 发表于 2016-2-3 09:41

非常感谢！祝：春节快乐，全家幸福！

PC8888

非常感谢！祝：春节快乐，全家幸福！

PC8888

雪舞子 发表于 2016-2-2 20:39
了却你的心愿，好好过个春节吧。

老师：你好！本VBA向表格充填数字程序非常好。在此谢谢！现在想把没有“/”的光度数量（红色）填入左边表格对应位置中，见左图。程序怎么改？能帮我改改吗？