Excel精英培训网

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

[已解决]提取数据的问题

[复制链接]
发表于 2013-6-16 06:45 | 显示全部楼层 |阅读模式
附件 提取数据附件.rar (9.28 KB, 下载次数: 15)
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
发表于 2013-6-16 07:01 | 显示全部楼层    本楼为最佳答案   
  1. Sub test()

  2.     On Error GoTo ErrorHandler
  3.    
  4.     Dim arr, arrResult()
  5.     Dim i As Long, j As Long, Match, k As Long
  6.    
  7.     arr = Range("a1").CurrentRegion
  8.     ReDim arrResult(1 To UBound(arr), 1 To UBound(arr, 2))
  9.    
  10.     Match = [h1].Value
  11.     For i = LBound(arr) To UBound(arr)
  12.         If arr(i, 4) = Match Then
  13.             k = k + 1
  14.             For j = LBound(arr, 2) To UBound(arr, 2)
  15.                 arrResult(k, j) = arr(i, j)
  16.             Next
  17.         End If
  18.     Next
  19.    
  20.     With Range("l1")
  21.         .Resize(k, UBound(arr, 2)).Value = arrResult
  22.         .CurrentRegion.EntireColumn.AutoFit
  23.     End With
  24.     MsgBox "提取完成"
  25.     Exit Sub
  26.    
  27. ErrorHandler:
  28.     MsgBox Err.Number & vbCrLf & _
  29.            Err.Description
  30. End Sub
复制代码

评分

参与人数 1金币 +1 收起 理由
Fbblg + 1 很给力!

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2013-6-16 07:05 | 显示全部楼层
hwc2ycy 发表于 2013-6-16 07:01

谢谢老师帮助!又快又准!
回复

使用道具 举报

发表于 2013-6-16 07:08 | 显示全部楼层
  1. Sub test()

  2.     On Error GoTo ErrorHandler
  3.    
  4.     Dim arr, arrResult()
  5.     Dim i As Long, j As Long, Match, k As Long
  6.    
  7.     '检测H1单元格有要查找的内容
  8.     If Len(Range("h1").Value) = 0 Then
  9.         MsgBox "H1单元格没有要匹配的值"
  10.         Exit Sub
  11.     End If
  12.    
  13.     '读入单元格数据到数组,并调整结果数组大小
  14.     arr = Range("a1").CurrentRegion
  15.     ReDim arrResult(1 To UBound(arr), 1 To UBound(arr, 2))
  16.    
  17.     '匹配值
  18.     Match = [h1].Value
  19.    
  20.     '数组第一维循环
  21.     For i = LBound(arr) To UBound(arr)
  22.         '检测第4列值是否匹配
  23.         If arr(i, 4) = Match Then
  24.             '符合条件的数量加1
  25.             k = k + 1
  26.             '把符合条件的整行数据循环写入结果数组
  27.             For j = LBound(arr, 2) To UBound(arr, 2)
  28.                 arrResult(k, j) = arr(i, j)
  29.             Next
  30.         End If
  31.     Next
  32.     '关属性
  33.     Application.ScreenUpdating = False
  34.     Application.DisplayAlerts = False
  35.     Application.EnableEvents = False
  36.     Application.Calculation = xlCalculationManual
  37.    
  38.     '数组数组写回单元格,列宽自适应
  39.     With Range("l1")
  40.         If Len(.Value) Then .CurrentRegion.ClearContents
  41.         .Resize(k, UBound(arr, 2)).Value = arrResult
  42.         .CurrentRegion.EntireColumn.AutoFit
  43.     End With
  44.    
  45.     '开属性
  46.     Application.ScreenUpdating = True
  47.     Application.DisplayAlerts = True
  48.     Application.EnableEvents = True
  49.     Application.Calculation = xlCalculationAutomatic
  50.    
  51.     '对话框提示完成
  52.     MsgBox "提取完成"
  53.     Exit Sub
  54.    
  55. ErrorHandler:
  56.     MsgBox Err.Number & vbCrLf & _
  57.            Err.Description
  58. End Sub
复制代码
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 02:53 , Processed in 0.594004 second(s), 15 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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