ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

   
高效办公必会的Office实战技巧 永久免费,网表让Excel秒变数据库 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel函数公式学习大典 职场充电黑科技, Office微视频教程 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 突破Excel限制,用活字格提高效率 12门Excel免费公开课任你学
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
查看: 191|回复: 19

[求助] 想在在同一个工作簿中,把各个表中的指定内容提取出来

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-2-13 22:34 | 显示全部楼层 |阅读模式
想在在同一个工作簿中,把各个表中的指定内容提取出来。公式、函数、VBa都可以

查询.rar

170.81 KB, 下载次数: 4

TA的精华主题

TA的得分主题

发表于 2018-2-14 01:20 来自手机 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-2-14 08:33 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2018-2-14 09:29 | 显示全部楼层
  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2.     If Target.Address <> "$C$4" Then Exit Sub
  3.     Set d = CreateObject("Scripting.Dictionary")
  4.     For Each sh In Worksheets
  5.         If sh.Name <> ActiveSheet.Name Then
  6.             ar = sh.UsedRange
  7.             For i = 3 To UBound(ar)
  8.                 d(ar(i, 3)) = ""
  9.             Next
  10.       End If
  11.     Next
  12.     k = Join(d.keys, ",")
  13.     With [C4].Validation
  14.         .Delete: .Add xlValidateList, , , k
  15.     End With
  16.     Set d = Nothing
  17. End Sub

  18. Private Sub Worksheet_Change(ByVal Target As Range)
  19.     If Target.Address <> "$C$4" Then Exit Sub
  20.     Dim sh As Worksheet
  21.     Dim r, i, s
  22.     Range("A7:AK100").ClearContents
  23.     Application.ScreenUpdating = False
  24.         s = 7
  25.         For Each sh In Worksheets
  26.             If sh.Name <> ActiveSheet.Name Then
  27.                 r = sh.[C1048576].End(3).Row
  28.                 For i = 3 To r
  29.                     If sh.Cells(i, 3) = Cells(4, 3) Then
  30.                         Cells(s, 1) = sh.Name
  31.                         For j = 1 To 37
  32.                             Cells(s, j + 1) = sh.Cells(i, j)
  33.                         Next
  34.                         s = s + 1
  35.                     End If
  36.                 Next
  37.             End If
  38.         Next
  39.     Application.ScreenUpdating = True
  40. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2018-2-14 16:09 | 显示全部楼层
  1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  2. Dim arr, brr(1 To 1000, 1 To 27), crr(1 To 1, 1 To 27)
  3. Dim ws As Worksheet
  4. With Worksheets("查询")
  5.   .[a7:ak100].ClearContents
  6. End With
  7. For Each ws In Worksheets
  8.   If ws.Name <> "查询" Then
  9.      With ws
  10.        n = 0
  11.         rw = .[c65536].End(3).Row
  12.         arr = .Range("c3:ak" & rw)
  13.            For i = 1 To UBound(arr)
  14.              n = n + 1
  15.              brr(n, 1) = ws.Name
  16.              brr(n, 2) = arr(i, 1)
  17.                For j = 11 To UBound(arr, 2)
  18.                  brr(n, j - 8) = arr(i, j)
  19.                Next
  20.           Next
  21.      End With
  22.       With Worksheets("查询")
  23.           For x = 1 To UBound(brr)
  24.              If Cells(4, "i") = brr(x, 2) Then
  25.                 For y = 1 To 27
  26.                   crr(1, y) = brr(x, y)
  27.                 Next
  28.              End If
  29.           Next
  30.       End With
  31.   End If
  32.   Worksheets("查询").[j65536].End(3).Offset(1, 0).Resize(1, 27) = crr
  33.   Erase crr
  34. Next
  35. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2018-2-14 16:10 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-2-14 16:42 | 显示全部楼层

感谢,学习中。有些地方没看懂,能帮我注释一下么?还有,我想提取出我需要的部分列,不想一行都提取,该怎么变动?

TA的精华主题

TA的得分主题

发表于 2018-2-14 17:07 | 显示全部楼层
呵呵  论坛上老师们帮助别人写代码一般都不写注释的

TA的精华主题

TA的得分主题

发表于 2018-2-14 17:09 | 显示全部楼层
想当初 我们学习时也是这样的   如果是为了学习  主要靠自己去解读代码  这需要一定的vba基础

TA的精华主题

TA的得分主题

发表于 2018-2-14 17:10 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

最新热点上一条 /1 下一条

关注官方微信,每天学会一个新技能

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

GMT+8, 2018-2-19 15:37 , Processed in 0.066922 second(s), 9 queries , Gzip On, MemCache On.

Powered by Discuz! X3.3

© 2001-2017 Wooffice Inc.

   

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

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

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