ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
楼主: tongtong61

[求助] 有偿求助!!关于vba的find函数

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-5-29 13:08 | 显示全部楼层
建議特定文字要考慮清楚些, 不然效果會差。
  1. <div><div>Sub zz()</div><div>Dim a, b(), p$, f$, c As New Collection, n&</div><div>a = Range("a1:a" & [a1048576].End(3).Row)</div><div>ReDim b(1 To UBound(a))</div><div>For i = 1 To UBound(a)</div><div>    b(i) = a(i, 1)</div><div>Next</div><div>With Application.FileDialog(msoFileDialogFolderPicker)</div><div>    .InitialFileName = ThisWorkbook.Path</div><div>    .Show</div><div>    If .SelectedItems.Count Then p = .SelectedItems(1) Else Exit Sub</div><div>End With</div><div>Application.ScreenUpdating = 0</div><div>f = Dir(p & "" & "*.xls*")</div><div>Do While f <> ThisWorkbook.Name And f <> ""</div><div>    Set wb = GetObject(p & "" & f)</div><div>    a = wb.Sheets(1).UsedRange</div><div>    wb.Close 0</div><div>    For i = 1 To UBound(a)</div><div>        For j = 2 To UBound(a, 2)</div><div>            a(i, 1) = a(i, 1) & "|" & a(i, j)</div><div>        Next</div><div>        For j = 1 To UBound(b)</div><div>            If InStr(a(i, 1), b(j)) > 0 Then</div><div>                c.Add f & "|" & a(i, 1)</div><div>                Exit For</div><div>            End If</div><div>        Next</div><div>    Next</div><div>    f = Dir</div><div>Loop</div><div>If c.Count = 0 Then Application.ScreenUpdating = 1: Exit Sub</div><div>Sheets(2).Activate</div><div>Sheets(2).UsedRange.Clear</div><div>ReDim b(1 To c.Count, 1 To 1000)</div><div>For i = 1 To c.Count</div><div>    a = Split(c(i), "|")</div><div>    For j = 0 To UBound(a)</div><div>        b(i, j + 1) = a(j)</div><div>    Next</div><div>    n = IIf(j > n, j, n)</div><div>Next</div><div>[a1].Resize(i - 1, n) = b</div><div>Application.ScreenUpdating = 1</div><div>End Sub</div></div><div></div>
复制代码



zz.zip

20.42 KB, 下载次数: 0

TA的精华主题

TA的得分主题

发表于 2020-5-29 13:38 | 显示全部楼层
  1. Sub zz()
  2. Dim a, b(), p$, f$, c As New Collection, n&, wb As Workbook
  3. a = Range("a1:a" & [a1048576].End(3).Row)
  4. ReDim b(1 To UBound(a))
  5. For i = 1 To UBound(a)
  6.     b(i) = a(i, 1)
  7. Next
  8. With Application.FileDialog(msoFileDialogFolderPicker)
  9.     .InitialFileName = ThisWorkbook.Path
  10.     .Show
  11.     If .SelectedItems.Count Then p = .SelectedItems(1) Else Exit Sub
  12. End With
  13. Application.ScreenUpdating = 0
  14. f = Dir(p & "" & "*.xls*")
  15. Do While f <> ThisWorkbook.Name And f <> ""
  16.     Set wb = GetObject(p & "" & f)
  17.     a = wb.Sheets(1).UsedRange
  18.     wb.Close 0
  19.     For i = 1 To UBound(a)
  20.         For j = 2 To UBound(a, 2)
  21.             a(i, 1) = a(i, 1) & "|" & a(i, j)
  22.         Next
  23.         For j = 1 To UBound(b)
  24.             If InStr(a(i, 1), b(j)) > 0 Then
  25.                 c.Add p & "|" & f & "|" & a(i, 1)
  26.                 Exit For
  27.             End If
  28.         Next
  29.     Next
  30.     f = Dir
  31. Loop
  32. If c.Count = 0 Then Application.ScreenUpdating = 1: Exit Sub
  33. Sheets(2).Activate
  34. Sheets(2).UsedRange.Clear
  35. ReDim b(1 To c.Count, 1 To 4096)
  36. For i = 1 To c.Count
  37.     a = Split(c(i), "|")
  38.     For j = 0 To UBound(a)
  39.         b(i, j + 1) = a(j)
  40.     Next
  41.     n = IIf(j > n, j, n)
  42. Next
  43. [a1].Resize(i - 1, n) = b
  44. Application.ScreenUpdating = 1
  45. End Sub
复制代码

zz.zip

18.68 KB, 下载次数: 8

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-5-29 16:10 | 显示全部楼层
wang-way 发表于 2020-5-29 11:58
zfb账号是企鹅邮箱84857038

给您发送了哈,如果能继续帮我解决一下,我继续发红包哈,谢谢

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-5-29 16:12 | 显示全部楼层
yylucke 发表于 2020-5-29 12:11
很简单啊
因为你的其他文件关键列的位置不同,你又不告诉关键列的标志,比如列名,还是其他规律。你提供的 ...

因为原文件列的关键列关键字是不一样的,所有要查找所有单元格

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-5-29 16:25 | 显示全部楼层

谢谢您,解决了我的问题,能留下您的支付宝账号之类的吗,向您表达一点点感谢之意!

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-5-29 16:29 | 显示全部楼层
tongtong61 发表于 2020-5-29 16:25
谢谢您,解决了我的问题,能留下您的支付宝账号之类的吗,向您表达一点点感谢之意!

不用了, 我是抱著學習的心來的。

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2020-5-29 16:59 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
tongtong61 发表于 2020-5-29 16:10
给您发送了哈,如果能继续帮我解决一下,我继续发红包哈,谢谢

还想 怎么继续处理 ?乐于帮助

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-5-30 21:34 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-5-30 23:10 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-6-6 21:25 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 14:54 , Processed in 0.052187 second(s), 13 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

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