Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 1684|回复: 6

[已解决]谢谢hwc2ycy老师,按N个关键词从三列中提取全部记录

[复制链接]
发表于 2013-7-16 10:48 | 显示全部楼层 |阅读模式
本帖最后由 lhj323323 于 2013-7-16 14:09 编辑

老师:
我需要根据一系列关键词,从另一表中的E、F、G三列中(三列有顺序优先)提取包含这些关键词的全部记录,导入到第三张表中
有点难,能力达不到,故,上论坛求助,先谢谢了

需求.rar (169.53 KB, 下载次数: 17)
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2013-7-16 11:56 | 显示全部楼层
  1. Sub 提取记录()
  2.     Dim arr, arrResult()
  3.     Dim arrKeywords
  4.     Dim lLastRow&, lRecord As Long
  5.     Dim strTemp As String
  6.     Dim blG As Boolean, blF As Boolean, blE As Boolean, blOK As Boolean
  7.     Dim i As Long, j As Long, k As Long
  8.    
  9.     arr = Worksheets("数据源").Range("a1").CurrentRegion.Value
  10.     ReDim arrResult(1 To UBound(arr), 1 To UBound(arr, 2))
  11.     With Worksheets("AAA")
  12.         lLastRow = .Cells(Rows.Count, "h").End(xlUp).Row
  13.         arrKeywords = .Range("h2:i" & lLastRow).Value
  14.     End With
  15.    
  16.     For i = LBound(arr) To UBound(arr)
  17.         blOK = False
  18.         For j = LBound(arrKeywords) To UBound(arrKeywords)
  19.             strTemp = "*" & arrKeywords(j, 1) & "*"
  20.             blG = arr(i, 7) Like strTemp
  21.             blF = arr(i, 6) Like strTemp
  22.             blE = arr(i, 5) Like strTemp
  23.             
  24.             Select Case True
  25.                 Case blG
  26.                     blOK = True
  27.                 Case blF
  28.                     blOK = True
  29.                 Case blE
  30.                     blOK = True
  31.             End Select
  32.             
  33.             If blOK Then
  34.                 lRecord = lRecord + 1
  35.                 For k = LBound(arr, 2) To UBound(arr, 2)
  36.                     arrResult(lRecord, k) = arr(i, k)
  37.                 Next
  38.                 Exit For
  39.             End If
  40.         Next
  41.     Next

  42.     If lRecord Then
  43.         With Worksheets("结果表")
  44.             lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
  45.             If lLastRow > 1 Then
  46.                 .Range("a2:g" & lLastRow).ClearContents
  47.             End If
  48.             .Range("a2").Resize(lRecord, UBound(arr, 2)).Value = arrResult
  49.         End With
  50.     End If
  51.     MsgBox "查询完成"
  52. End Sub
复制代码
回复

使用道具 举报

发表于 2013-7-16 11:58 | 显示全部楼层
股票代码显示不对,深市的0全没了,
  1. Sub 提取记录()
  2.     Dim arr, arrResult()
  3.     Dim arrKeywords
  4.     Dim lLastRow&, lRecord As Long
  5.     Dim strTemp As String
  6.     Dim blG As Boolean, blF As Boolean, blE As Boolean, blOK As Boolean
  7.     Dim i As Long, j As Long, k As Long
  8.    
  9.     arr = Worksheets("数据源").Range("a1").CurrentRegion.Value
  10.     ReDim arrResult(1 To UBound(arr), 1 To UBound(arr, 2))
  11.     With Worksheets("AAA")
  12.         lLastRow = .Cells(Rows.Count, "h").End(xlUp).Row
  13.         arrKeywords = .Range("h2:i" & lLastRow).Value
  14.     End With
  15.    
  16.     For i = LBound(arr) To UBound(arr)
  17.         blOK = False
  18.         For j = LBound(arrKeywords) To UBound(arrKeywords)
  19.             strTemp = "*" & arrKeywords(j, 1) & "*"
  20.             blG = arr(i, 7) Like strTemp
  21.             blF = arr(i, 6) Like strTemp
  22.             blE = arr(i, 5) Like strTemp
  23.             
  24.             Select Case True
  25.                 Case blG
  26.                     blOK = True
  27.                 Case blF
  28.                     blOK = True
  29.                 Case blE
  30.                     blOK = True
  31.             End Select
  32.             
  33.             If blOK Then
  34.                 lRecord = lRecord + 1
  35.                 arrResult(lRecord, 1) = "'" & Format(arr(i, 1), "000000")
  36.                 For k = LBound(arr, 2) + 1 To UBound(arr, 2)
  37.                     arrResult(lRecord, k) = arr(i, k)
  38.                 Next
  39.                 Exit For
  40.             End If
  41.         Next
  42.     Next

  43.     If lRecord Then
  44.         With Worksheets("结果表")
  45.             lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
  46.             If lLastRow > 1 Then
  47.                 .Range("a2:g" & lLastRow).ClearContents
  48.             End If
  49.             .Range("a2").Resize(lRecord, UBound(arr, 2)).Value = arrResult
  50.         End With
  51.     End If
  52.     MsgBox "查询完成"
  53. End Sub
复制代码
回复

使用道具 举报

发表于 2013-7-16 12:01 | 显示全部楼层    本楼为最佳答案   
  1. Sub 提取记录()
  2.     Dim arr, arrResult(), arrKeywords
  3.     Dim lLastRow&, lRecord As Long
  4.     Dim strTemp As String
  5.     Dim blG As Boolean, blF As Boolean, blE As Boolean, blOK As Boolean
  6.     Dim i As Long, j As Long, k As Long
  7.    
  8.     '源数据
  9.     arr = Worksheets("数据源").Range("a1").CurrentRegion.Value
  10.     ReDim arrResult(1 To UBound(arr), 1 To UBound(arr, 2))
  11.    
  12.     '关键字
  13.     With Worksheets("AAA")
  14.         lLastRow = .Cells(Rows.Count, "h").End(xlUp).Row
  15.         arrKeywords = .Range("h2:i" & lLastRow).Value
  16.     End With
  17.    
  18.     '数据行循环
  19.     For i = LBound(arr) To UBound(arr)
  20.         blOK = False
  21.         '关键字循环
  22.         For j = LBound(arrKeywords) To UBound(arrKeywords)
  23.             strTemp = "*" & arrKeywords(j, 1) & "*"
  24.             'G列匹配
  25.             blG = arr(i, 7) Like strTemp
  26.             'F列匹配
  27.             blF = arr(i, 6) Like strTemp
  28.             'E列匹配
  29.             blE = arr(i, 5) Like strTemp
  30.             
  31.             Select Case True
  32.                 Case blG
  33.                     blOK = True
  34.                 Case blF
  35.                     blOK = True
  36.                 Case blE
  37.                     blOK = True
  38.             End Select
  39.             
  40.             '数据匹配
  41.             If blOK Then
  42.                 '行号加1
  43.                 lRecord = lRecord + 1
  44.                 '股票代码
  45.                 arrResult(lRecord, 1) = "'" & Format(arr(i, 1), "000000")
  46.                 '余下数据
  47.                 For k = LBound(arr, 2) + 1 To UBound(arr, 2)
  48.                     arrResult(lRecord, k) = arr(i, k)
  49.                 Next
  50.                 '结束循环
  51.                 Exit For
  52.             End If
  53.         Next
  54.     Next

  55.     If lRecord Then
  56.         With Worksheets("结果表")
  57.             '判断是否需要清除原有内容
  58.             lLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
  59.             If lLastRow > 1 Then
  60.                 .Range("a2:g" & lLastRow).ClearContents
  61.             End If
  62.             '写入数据
  63.             .Range("a2").Resize(lRecord, UBound(arr, 2)).Value = arrResult
  64.         End With
  65.     End If
  66.     MsgBox "查询完成"
  67. End Sub
复制代码
回复

使用道具 举报

发表于 2013-7-16 12:17 | 显示全部楼层
  1. Private Sub CommandButton2_Click()
  2.     Dim arr, brr, crr
  3.     Dim i&, j&, nub, iRow
  4.         arr = Sheets("AAA").Range("H2:H6")
  5.         brr = Sheets("数据源").UsedRange
  6.         ReDim crr(1 To UBound(brr), 1 To 7)
  7.             For i = 1 To UBound(arr)
  8.                 For j = 2 To UBound(brr)
  9.                     If brr(j, 7) Like "*" & arr(i, 1) & "*" Or brr(j, 6) Like "*" & arr(i, 1) & "*" Or brr(j, 5) Like "*" & arr(i, 1) & "*" Then
  10.                         iRow = iRow + 1
  11.                         crr(iRow, 1) = brr(j, 1)
  12.                         crr(iRow, 2) = brr(j, 2)
  13.                         crr(iRow, 3) = brr(j, 3)
  14.                         crr(iRow, 4) = brr(j, 4)
  15.                         crr(iRow, 5) = brr(j, 5)
  16.                         crr(iRow, 6) = brr(j, 6)
  17.                         crr(iRow, 7) = brr(j, 7)
  18.                     End If
  19.                 Next
  20.             Next
  21.     Sheets("结果表").Range("A2").Resize(UBound(crr), 7) = crr
  22. End Sub
复制代码

需求.zip

273.01 KB, 下载次数: 4

回复

使用道具 举报

发表于 2013-7-16 13:16 | 显示全部楼层
犯了同样的错误,没有处理股票代码的0。
修改了下:
  1. Private Sub CommandButton2_Click()
  2.     Dim arr, brr, crr
  3.     Dim i&, j&, nub, iRow
  4.         arr = Sheets("AAA").Range("H2:H6")
  5.         brr = Sheets("数据源").UsedRange
  6.         ReDim crr(1 To UBound(brr), 1 To 7)
  7.             For i = 1 To UBound(arr)
  8.                 For j = 2 To UBound(brr)
  9.                     If brr(j, 7) Like "*" & arr(i, 1) & "*" Or brr(j, 6) Like "*" & arr(i, 1) & "*" Or brr(j, 5) Like "*" & arr(i, 1) & "*" Then
  10.                         iRow = iRow + 1
  11.                         crr(iRow, 1) = brr(j, 1)
  12.                         crr(iRow, 2) = brr(j, 2)
  13.                         crr(iRow, 3) = brr(j, 3)
  14.                         crr(iRow, 4) = brr(j, 4)
  15.                         crr(iRow, 5) = brr(j, 5)
  16.                         crr(iRow, 6) = brr(j, 6)
  17.                         crr(iRow, 7) = brr(j, 7)
  18.                     End If
  19.                 Next
  20.             Next
  21.     Sheets("结果表").Activate
  22.         With ActiveSheet
  23.             .Range("A2:G" & Range("a65536").End(3).Row).ClearContents
  24.             .Range("A:A").NumberFormatLocal = "@"
  25.             .Range("A2").Resize(UBound(crr), 7) = crr
  26.         End With
  27. End Sub
复制代码

需求.zip

268.73 KB, 下载次数: 5

回复

使用道具 举报

 楼主| 发表于 2013-7-16 14:08 | 显示全部楼层
sliang28 发表于 2013-7-16 13:16
犯了同样的错误,没有处理股票代码的0。
修改了下:

sliang28老师:

谢谢您的关注

您的语句,提取出1617条记录,经核实,实际应该只有748条,原因是重复提取
我截取了一部分,请看

600539
ST 狮 头               
ST 狮 头               
600539
ST 狮 头               
ST 狮 头               
600793
ST 宜 纸               
ST 宜 纸               
002136
安 纳 达               
安 纳 达               
600761
安徽合力               
安徽合力               
600761
安徽合力               
安徽合力               
600502
安徽水利               
安徽水利               
600502
安徽水利               
安徽水利               
000868
安凯客车               
安凯客车               
000868
安凯客车               
安凯客车               
600298
安琪酵母               
安琪酵母               
000969
安泰科技               
安泰科技               
000969
安泰科技               
安泰科技               
000969
安泰科技               
安泰科技               
600336
澳 柯 玛               
澳 柯 玛               
600336
澳 柯 玛               
澳 柯 玛               
600581
八一钢铁               
八一钢铁               
600581
八一钢铁               
八一钢铁               
600581
八一钢铁               
八一钢铁               
600721
百 花 村               
百 花 村               
600468
百利电气               
百利电气               
600468
百利电气               
百利电气               
600019
宝钢股份               
宝钢股份               
600019
宝钢股份               
宝钢股份               
600019
宝钢股份               
宝钢股份               
600379
宝光股份               
宝光股份               
600973
宝胜股份               
宝胜股份               
600973
宝胜股份               
宝胜股份               
600456
宝钛股份               
宝钛股份               
600456
宝钛股份               
宝钛股份               
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-3-29 03:37 , Processed in 0.506369 second(s), 9 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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