[已解决]VBA：搜寻一列数据中的特定值，取另一列的同行数值

lijian8003 · 发表于 2021-11-3 17:00

本帖最后由 lijian8003 于 2021-11-3 17:27 编辑

Sheet2
BA列       BB列
...       ...
张三       5
...       ...
李四       4
王五       7
...       ...
赵六       7
王五       7
...       ...
王五       7

Sheet1
AF2=4，AF3=1，AF4=2

1、现欲搜寻Sheet2 BB列中有哪些单元格，与Sheet1 AF2+AF3+AF4=7相同，并提取Sheet2 BA列同行对应单元格数值，依次写入Sheet1 BA1 BA2 BA3...（上例提取：王五赵六王五王五）。

2、上例提取的王五赵六王五王五，欲去掉重复值，只保留王五赵六。

两个宏代码恳请都贴出，以利于揣摩比较学习。

最佳答案

月排行榜 / 总排行榜

lisongmei

2021-11-3 17:59

Option Explicit
Sub 搜寻()
Dim x, i, k As Long
Dim arr, arr2(1 To 100000, 1 To 1)
x = Application.WorksheetFunction.Sum(Sheet1.Range("AF2:AF4"))
arr = Sheet2.Range("ba1:bb" & Sheet2.[Bb100000].End(xlUp).Row)
For i = 1 To UBound(arr)
If arr(i, 2) = x Then
k = k + 1
arr2(k, 1) = arr(i, 1)
End If
Next
Sheet1.[ba1].Resize(k, 1) = arr2
End Sub
Sub 去重()
Dim dicc, arr, arr1, i%
Set dicc = CreateObject("scripting.dictionary")
arr = Sheet1.Range("ba1:ba" & Sheet1.[Ba100000].End(xlUp).Row)
Sheet1.Range("ba1:ba100000").ClearContents
For i = 1 To UBound(arr)
dicc(arr(i, 1)) = ""
Next
Sheet1.[ba1].Resize(UBound(dicc.keys) + 1) = Application.Transpose(dicc.keys)
End Sub

复制代码

跳转到最佳答案楼层

lisongmei · 发表于 2021-11-3 17:59

这个最佳答案由 lisongmei 给出，感谢 lisongmei 的回答。

单击隐藏图章

Option Explicit
Sub 搜寻()
Dim x, i, k As Long
Dim arr, arr2(1 To 100000, 1 To 1)
x = Application.WorksheetFunction.Sum(Sheet1.Range("AF2:AF4"))
arr = Sheet2.Range("ba1:bb" & Sheet2.[Bb100000].End(xlUp).Row)
For i = 1 To UBound(arr)
If arr(i, 2) = x Then
k = k + 1
arr2(k, 1) = arr(i, 1)
End If
Next
Sheet1.[ba1].Resize(k, 1) = arr2
End Sub
Sub 去重()
Dim dicc, arr, arr1, i%
Set dicc = CreateObject("scripting.dictionary")
arr = Sheet1.Range("ba1:ba" & Sheet1.[Ba100000].End(xlUp).Row)
Sheet1.Range("ba1:ba100000").ClearContents
For i = 1 To UBound(arr)
dicc(arr(i, 1)) = ""
Next
Sheet1.[ba1].Resize(UBound(dicc.keys) + 1) = Application.Transpose(dicc.keys)
End Sub

复制代码

lijian8003 · 发表于 2021-11-3 18:04

lisongmei 发表于 2021-11-3 17:59

万分感谢！代码运行流畅，结果正确。

lijian8003 · 发表于 2021-11-3 18:19

lisongmei 发表于 2021-11-3 17:59

感谢帮助！去重的结果，在搜寻后直接写入Sheet1 BA列，代码如何修改？（非先搜寻到全部有重复的数值并写入Sheet1 BA列后，再对Sheet1 BA列去重。）

lisongmei · 发表于 2021-11-3 18:33

本帖最后由 lisongmei 于 2021-11-3 18:36 编辑

lijian8003 发表于 2021-11-3 18:19
感谢帮助！去重的结果，在搜寻后直接写入Sheet1 BA列，代码如何修改？（非先搜寻到全部有重复的数值并写 ...

那就直接用一个字典就搞定了。改就是重写。。。。

Sub test()
Dim x, i, k As Long, dicc
Dim arr, arr2(1 To 100000, 1 To 1)
Set dicc = CreateObject("scripting.dictionary")
Sheet1.Range("ba1:ba100000").ClearContents
x = Application.WorksheetFunction.Sum(Sheet1.Range("AF2:AF4"))
arr = Sheet2.Range("ba1:bb" & Sheet2.[Bb100000].End(xlUp).Row)
For i = 1 To UBound(arr)
If arr(i, 2) = x Then
dicc(arr(i, 1)) = ""
End If
Next
Sheet1.[ba1].Resize(UBound(dicc.keys) + 1) = Application.Transpose(dicc.keys)
End Sub

复制代码

lijian8003 · 发表于 2021-11-3 18:43

lisongmei 发表于 2021-11-3 18:33
那就直接用一个字典就搞定了。改就是重写。。。。

学习了。愿您工作生活蒸蒸日上！

lijian8003 · 发表于 2021-11-3 23:19

本帖最后由 lijian8003 于 2021-11-3 23:46 编辑

lisongmei 发表于 2021-11-3 18:33
那就直接用一个字典就搞定了。改就是重写。。。。

老师您好！如果没有搜索到数值，则代码运行出错。实际运用时，Sheet2 BB列中常常会没有特定搜索的数值，此时Sheet1 BA列则输出为空。如何加个判断，烦请老师不吝指教。

lisongmei · 发表于 2021-11-3 23:50

lijian8003 发表于 2021-11-3 23:19
老师您好！如果没有搜索到数值，则代码运行出错。实际运用时，Sheet2 BB列中常常会没有特定搜索的数值， ...

一般在代码刚开始加句：
On Error Resume Next

lijian8003 · 发表于 2021-11-4 00:06

lisongmei 发表于 2021-11-3 23:50
一般在代码刚开始加句：
On Error Resume Next

OK 问题解决了。谢谢您！

lijian8003 · 发表于 2021-11-4 19:22

本帖最后由 lijian8003 于 2021-11-4 19:56 编辑

lisongmei 发表于 2021-11-3 18:33
那就直接用一个字典就搞定了。改就是重写。。。。

老师，您好！有问题询问：
x = Application.WorksheetFunction.Sum(Sheet1.Range("AF2:AF4"))
如果取值范围是 Sum（Range("AF2:AF4")）- n 与 Sum（Range("AF2:AF4") ）之间，n 是 1 2 3 4 ...（例如：Sum（Range("AF2:AF4")）=10，n=3，取值范围是 7-10）
宏代码该如何表达？

		自动登录	找回密码
密码			注册