ExcelHome技术论坛

 找回密码
 免费注册
QQ登录 只需一步,快速开始
   
高效办公必会的Office99uu优优 永久免费,网表让Excel秒变数据库 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel函数公式学习大典 职场充电黑科技, Office微99uu优优 免费下载Excel行业应用视频
300集Office 2010微99uu优优 Tableau-数据可视化工具 突破Excel限制,用活字格提高效率 12门Excel免费公开课任你学
你的Excel 201099uu优优学习锦囊 欲罢不能, 过目难忘的 Office 新界面 免费的Excel考勤计算系统
查看: 245|回复: 19
打印 上一主题 下一主题

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

[复制链接]
TA的精华主题TA的得分主题
跳转到指定楼层
1
发表于 2018-2-13 22:34 | 只看该作者 回帖奖励 |倒序浏览 |阅读模式
想在在同一个工作簿中,把各个表中的指定内容提取出来。公式、函数、VBa都可以
查询.rar 170.81 KB, 下载次数: 6
TA的精华主题TA的得分主题
2
发表于 2018-2-14 01:20 来自手机 | 只看该作者
TA的精华主题TA的得分主题
3
 楼主| 发表于 2018-2-14 08:33 | 只看该作者
TA的精华主题TA的得分主题
4
发表于 2018-2-14 09:29 | 只看该作者
  • Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  •     If Target.Address <> "$C$4" Then Exit Sub
  •     Set d = CreateObject("Scripting.Dictionary")
  •     For Each sh In Worksheets
  •         If sh.Name <> ActiveSheet.Name Then
  •             ar = sh.UsedRange
  •             For i = 3 To UBound(ar)
  •                 d(ar(i, 3)) = ""
  •             Next
  •       End If
  •     Next
  •     k = Join(d.keys, ",")
  •     With [C4].Validation
  •         .Delete: .Add xlValidateList, , , k
  •     End With
  •     Set d = Nothing
  • End Sub

  • Private Sub Worksheet_Change(ByVal Target As Range)
  •     If Target.Address <> "$C$4" Then Exit Sub
  •     Dim sh As Worksheet
  •     Dim r, i, s
  •     Range("A7:AK100").ClearContents
  •     Application.ScreenUpdating = False
  •         s = 7
  •         For Each sh In Worksheets
  •             If sh.Name <> ActiveSheet.Name Then
  •                 r = sh.[C1048576].End(3).Row
  •                 For i = 3 To r
  •                     If sh.Cells(i, 3) = Cells(4, 3) Then
  •                         Cells(s, 1) = sh.Name
  •                         For j = 1 To 37
  •                             Cells(s, j + 1) = sh.Cells(i, j)
  •                         Next
  •                         s = s + 1
  •                     End If
  •                 Next
  •             End If
  •         Next
  •     Application.ScreenUpdating = True
  • End Sub
  • 复制代码
    TA的精华主题TA的得分主题
    5
    发表于 2018-2-14 16:09 | 只看该作者
  • Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  • Dim arr, brr(1 To 1000, 1 To 27), crr(1 To 1, 1 To 27)
  • Dim ws As Worksheet
  • With Worksheets("查询")
  •   .[a7:ak100].ClearContents
  • End With
  • For Each ws In Worksheets
  •   If ws.Name <> "查询" Then
  •      With ws
  •        n = 0
  •         rw = .[c65536].End(3).Row
  •         arr = .Range("c3:ak" & rw)
  •            For i = 1 To UBound(arr)
  •              n = n + 1
  •              brr(n, 1) = ws.Name
  •              brr(n, 2) = arr(i, 1)
  •                For j = 11 To UBound(arr, 2)
  •                  brr(n, j - 8) = arr(i, j)
  •                Next
  •           Next
  •      End With
  •       With Worksheets("查询")
  •           For x = 1 To UBound(brr)
  •              If Cells(4, "i") = brr(x, 2) Then
  •                 For y = 1 To 27
  •                   crr(1, y) = brr(x, y)
  •                 Next
  •              End If
  •           Next
  •       End With
  •   End If
  •   Worksheets("查询").[j65536].End(3).Offset(1, 0).Resize(1, 27) = crr
  •   Erase crr
  • Next
  • End Sub
  • 复制代码
    TA的精华主题TA的得分主题
    6
    发表于 2018-2-14 16:10 | 只看该作者
    TA的精华主题TA的得分主题
    7
     楼主| 发表于 2018-2-14 16:42 | 只看该作者

    感谢,学习中。有些地方没看懂,能帮我注释一下么?还有,我想提取出我需要的部分列,不想一行都提取,该怎么变动?
    TA的精华主题TA的得分主题
    8
    发表于 2018-2-14 17:07 | 只看该作者
    呵呵  论坛上老师们帮助别人写代码一般都不写注释的
    TA的精华主题TA的得分主题
    9
    发表于 2018-2-14 17:09 | 只看该作者
    想当初 我们学习时也是这样的   如果是为了学习  主要靠自己去解读代码  这需要一定的vba基础
    TA的精华主题TA的得分主题
    10
    发表于 2018-2-14 17:10 | 只看该作者
    您需要登录后才可以回帖 登录 | 免费注册
    本版积分规则
    关闭

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

    关注官方微信,每天学会一个新技能
    手机版|关于我们|联系我们|ExcelHome GMT+8, 2018-2-26 09:07 , Processed in 0.078221 second(s), 17 queries , Gzip On, MemCache On.
    Powered by Discuz! X3.4 © 2001-2017 Wooffice Inc.
        沪公网安备 31011702000001号 沪ICP备11019229号 本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师
    快速回复 返回顶部 返回列表
    99uu优优