如何用VBA取B列名称和对应坐标值？（鲜花）

jjmysjg

留下记号，一会看看结果

约定的童话

ykqrs 发表于 2018-8-16 14:47

大神，还是不对，结果还是有差异，22楼代码可以实现

ykqrs

约定的童话 发表于 2018-8-17 13:44
大神，还是不对，结果还是有差异，22楼代码可以实现

那就参照22楼老师的代码改一下就行了

1. Sub qq()
   
2. Dim d, arr, i%, j%, brr(), s1#, s2#, t
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. arr = [a1].CurrentRegion
   
5. For i = 1 To UBound(arr)
   
6. If Not d.exists(arr(i, 2)) Then
   
7. d(arr(i, 2)) = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 5)
   
8. Else
   
9. s1 = Sqr(arr(i, 3) ^ 2 + arr(i, 4) ^ 2)
   
10. s2 = Sqr(Val(Split(d(arr(i, 2)), "|")(2)) ^ 2 + Val(Split(d(arr(i, 2)), "|")(3)) ^ 2)
    
11. If s1 < s2 Then
    
12. d(arr(i, 2)) = arr(i, 1) & "|" & arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4) & "|" & arr(i, 5)
    
13. End If
    
14. End If
    
15. Next
    
16. t = d.items
    
17. ReDim brr(1 To d.Count, 1 To 5)
    
18. For i = 1 To d.Count
    
19. For j = 1 To 5
    
20. brr(i, j) = Split(t(i - 1), "|")(j - 1)
    
21. Next
    
22. Next
    
23. Sheet2.Cells.Clear
    
24. Sheet2.[a1].Resize(d.Count, 5) = brr
    
25. End Sub
    

复制代码

约定的童话

ykqrs 发表于 2018-8-17 14:03
那就参照22楼老师的代码改一下就行了

强............强！

zhangcheng6688

ykqrs 发表于 2018-8-17 14:03
那就参照22楼老师的代码改一下就行了

厉害了！！！！！！