ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[求助] 请教一个学校常用的遍历文件夹写入对应数据的VBA

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-10-15 16:28 | 显示全部楼层 |阅读模式
请教一个学校常用的遍历文件夹写入对应数据的VBA,

要求,在工作簿中的汇总表,添加一个按钮,实现以下功能       



        1,工作表“一年级”,情况第4行开始往后的数据。并从第4行开始,写入数据,数据来源于文件夹内除了本汇总电子表格以外的所有电子表格,里面的对应的工作表“一年级”中的数据有效数据, 并且标出位置(来源于哪个电子表格),忽略原来工作表中的序号,待全部写入完毕,重新赋予序号,
        2  工作表二年级——六年级,同上
        类似结果,见汇总工作簿中的工作表  一年级——六年级


因为这个经常用到,但是自己对字典又不是很熟悉,特请教,谢谢。

遍历写入对应数据.rar

66.39 KB, 下载次数: 28

TA的精华主题

TA的得分主题

发表于 2019-10-15 16:31 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-10-15 16:34 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
先帮你顶一下。

TA的精华主题

TA的得分主题

发表于 2019-10-15 16:46 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
很好的例子,昨天写了一个多文件夹里的同名工作簿汇总,今天遇到了一个不同工作簿里同名工作表数据汇总。晚上试试看。

TA的精华主题

TA的得分主题

发表于 2019-10-15 16:48 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
汇总表里已经有学校名称了,还需要在后面H列添加来源工作簿名称吗?

TA的精华主题

TA的得分主题

发表于 2019-10-15 17:15 | 显示全部楼层
要下班了,仓促写了一个。请测试。

Sub test() '多工作薄打开模板mp与mf
    Dim mp$, mf$ '定义变量类型
    Application.DisplayAlerts = False '禁止弹出警告
    Application.ScreenUpdating = False '禁止屏幕刷新
    ar = Array("一年级", "二年级", "三年级", "四年级", "五年级", "六年级")
    mp = ThisWorkbook.Path & "\" '有此代码工作薄地址
    mf = Dir(mp & "*.xl*") '显示文件全名(可用通配符)
    Do
       If mf <> ThisWorkbook.Name Then '如果mf <>有代码工作薄文件名,就……
          Set dk = Workbooks.Open(mp & mf) '打开指定工作薄
                n = n + 1
                For Each sht In dk.Sheets(ar)
                        r = sht.[b65536].End(3).Row
                        Set sh = ThisWorkbook.Sheets(sht.Name)
                        sh.[a2] = sht.Name & " 学生名册"
                        If n = 1 Then sh.[a4:h60000].ClearContents
                        r1 = sh.[b65536].End(3).Row + 1
                        sht.Range("b4:f" & r).Copy: sh.Cells(r1, 2).PasteSpecial Paste:=xlPasteValues
                        sh.Range(sh.Cells(r1, 8), sh.Cells(r1 + r - 4, 8)) = mf
                Next sht
          dk.Close True '关闭指定工作薄(保存→True;不保存→False)
       End If
       mf = Dir '显示下一个工作薄文件名
        If mf = "" Then Exit Do '如果工作薄文件名为“空”,则退出Do循环
    Loop While ThisWorkbook.Name <> "" 'mf有代码工作薄文件名不为空,就进行Do循环
    For Each sh1 In ThisWorkbook.Sheets(ar)
        r2 = sh1.[b65536].End(3).Row
        For i = 4 To r2
                sh1.Cells(i, 1) = i - 3
        Next i
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-10-15 21:29 | 显示全部楼层
先来一个吧。
  1. Sub 汇总()
  2.     Dim FilName As String, PathStr As String
  3.     Dim m%, n&
  4.     Dim arr
  5.     Dim Wbook As Object, Sht As Worksheet
  6.     Application.ScreenUpdating = False
  7.     With ThisWorkbook
  8.         For Each Sht In .Worksheets
  9.             With Sht
  10.                 If .Name <> "汇总" Then
  11.                     .Range("A4:F" & .Cells(Rows.Count, 2).End(xlUp).Row + 1).ClearContents
  12.                 End If
  13.             End With
  14.         Next
  15.     End With
  16.     PathStr = ThisWorkbook.Path & ""
  17.     FilName = Dir(PathStr & "*.xls*")
  18.     Do While FilName <> ""
  19.         If FilName <> ThisWorkbook.Name Then
  20.             m = m + 1    '工作簿计数
  21.             Set Wbook = GetObject(PathStr & FilName)   '获取找到的工作簿
  22.             For Each Sht In Wbook.Worksheets                     '对工作簿里的工作表进行循环取值
  23.                 With Sht
  24.                     arr = .Range("B4:F" & .Cells(Rows.Count, 2).End(xlUp).Row)
  25.                 End With
  26.                 With ThisWorkbook.Worksheets(Sht.Name)
  27.                     n = .Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row     '获取对应工作表里第一个非空行
  28.                     .Range("B" & n).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
  29.                     .Range("A" & n).Resize(UBound(arr, 1), 1) = "=N(" & .Range("A" & n - 1).Address(0, 0) & ")+1"
  30.                 End With
  31.             Next
  32.             Wbook.Close False        '取完数据后关闭工作簿。
  33.         End If
  34.         FilName = Dir
  35.     Loop
  36.     Application.ScreenUpdating = True
  37.     MsgBox "所有工作簿已经汇总完毕!共计汇总了" & m & "个工作簿。"
  38. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2019-10-15 21:34 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-10-16 11:33 | 显示全部楼层
谢谢上面的老师。马上测试,刚才提及的里面有学校名字,但是有些是没有的,所以才需要标记。

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-10-16 12:17 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
假如,不局限于F列这个位置,而是整行复制过来,需要修改哪个代码?
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-29 15:32 , Processed in 0.051868 second(s), 14 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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