设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 字典查询最小距离求助
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 1860|回复: 3

[已解决]字典查询最小距离求助

[复制链接]
jk0932
发表于 2016-1-7 10:21 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 jk0932 于 2016-1-7 16:20 编辑

如附件已经给出了距离计算函数Distance，
原始输入数据包含，“Sheet原始数据”和将“sheet输出”中的ABCD四列
现在需要实现，通过“Sheet输出”的ABCD四列，在《Sheet原始数据》中进行查找出两个最小值的cellName，分别填入F和H列；
算法如下：
以A2：D4单元格值为列：
1，在《Sheet原始数据》表格内C：D列，查找和《Sheet输出》C2：D2单元格值不相同，且《Sheet输出》B2相等《Sheet原始数据》B列，通过遍历和距离函数计算出该条件下的最小距离，将该值填入《Sheet输出》E2，同时将《Sheet原始数据》A列对应最小值的CellName填入F2；
2，在《Sheet原始数据》表格内C：D列，查找和《Sheet输出》C2：D2单元格值均不相同，且《Sheet输出》B2不等《Sheet原始数据》B列，通过遍历和距离函数计算出该条件下最小距离，将该值填入《Sheet输出》G2，同时将《Sheet原始数据》A列对应最小值的CellName填入H2；
3，循环计算出《Sheet输出》表格内的所有结果；
谢谢！
最佳答案
月排行榜 / 总排行榜
grf1973
2016-1-7 14:54
判断条件大于小于号搞错了。。。。。
  1. Sub 计算()
  2.     Dim x#, y#, x1#, y1#
  3.     arr = Sheets("原始数据").[a1].CurrentRegion
  4.     brr = Sheets("输出").[a1].CurrentRegion
  5.     For i = 2 To UBound(brr)
  6.         x = brr(i, 3): y = brr(i, 4): pci = brr(i, 2)
  7.         min1 = 100000: min2 = 100000
  8.         For j = 2 To UBound(arr)
  9.             x1 = arr(j, 3): y1 = arr(j, 4)
  10.             celname = arr(j, 1) & "(A" & j & ")"
  11.             If x1 <> x And y1 <> y Then
  12.                 s = Distance(x, y, x1, y1)
  13.                 If arr(j, 2) = pci Then
  14.                     If min1 > s Then
  15.                         min1 = s
  16.                         brr(i, 5) = s
  17.                         brr(i, 6) = celname
  18.                     End If
  19.                 Else
  20.                     If min2 > s Then
  21.                         min2 = s
  22.                         brr(i, 7) = s
  23.                         brr(i, 8) = celname
  24.                     End If
  25.                 End If
  26.             End If
  27.         Next
  28.     Next
  29.     Sheets("输出").[a1].CurrentRegion = brr
  30. End Sub
复制代码

求助.rar

236.97 KB, 下载次数: 3
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
grf1973
发表于 2016-1-7 14:51 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
  1. Sub 计算()
  2.     Dim x#, y#, x1#, y1#
  3.     arr = Sheets("原始数据").[a1].CurrentRegion
  4.     brr = Sheets("输出").[a1].CurrentRegion
  5.     For i = 2 To UBound(brr)
  6.         x = brr(i, 3): y = brr(i, 4): pci = brr(i, 2)
  7.         min1 = 100000: min2 = 100000
  8.         For j = 2 To UBound(arr)
  9.             x1 = arr(j, 3): y1 = arr(j, 4)
  10.             celname = arr(j, 1) & "(A" & j & ")"
  11.             If x1 <> x And y1 <> y Then
  12.                 s = Distance(x, y, x1, y1)
  13.                 If arr(j, 2) = pci Then
  14.                     If min1 < s Then
  15.                         min1 = s
  16.                         brr(i, 5) = s
  17.                         brr(i, 6) = celname
  18.                     End If
  19.                 Else
  20.                     If min2 < s Then
  21.                         min2 = s
  22.                         brr(i, 7) = s
  23.                         brr(i, 8) = celname
  24.                     End If
  25.                 End If
  26.             End If
  27.         Next
  28.     Next
  29.     Sheets("输出").[a1].CurrentRegion = brr
  30. End Sub
复制代码
回复

使用道具 举报

grf1973
发表于 2016-1-7 14:52 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
请看附件。

求助.rar

244.08 KB, 下载次数: 1
回复

使用道具 举报

grf1973
发表于 2016-1-7 14:54 | 显示全部楼层    本楼为最佳答案   
判断条件大于小于号搞错了。。。。。
  1. Sub 计算()
  2.     Dim x#, y#, x1#, y1#
  3.     arr = Sheets("原始数据").[a1].CurrentRegion
  4.     brr = Sheets("输出").[a1].CurrentRegion
  5.     For i = 2 To UBound(brr)
  6.         x = brr(i, 3): y = brr(i, 4): pci = brr(i, 2)
  7.         min1 = 100000: min2 = 100000
  8.         For j = 2 To UBound(arr)
  9.             x1 = arr(j, 3): y1 = arr(j, 4)
  10.             celname = arr(j, 1) & "(A" & j & ")"
  11.             If x1 <> x And y1 <> y Then
  12.                 s = Distance(x, y, x1, y1)
  13.                 If arr(j, 2) = pci Then
  14.                     If min1 > s Then
  15.                         min1 = s
  16.                         brr(i, 5) = s
  17.                         brr(i, 6) = celname
  18.                     End If
  19.                 Else
  20.                     If min2 > s Then
  21.                         min2 = s
  22.                         brr(i, 7) = s
  23.                         brr(i, 8) = celname
  24.                     End If
  25.                 End If
  26.             End If
  27.         Next
  28.     Next
  29.     Sheets("输出").[a1].CurrentRegion = brr
  30. End Sub
复制代码

求助.rar

244.21 KB, 下载次数: 7
回复

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-25 10:25 , Processed in 1.072791 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表