问答文章1 问答文章501 问答文章1001 问答文章1501 问答文章2001 问答文章2501 问答文章3001 问答文章3501 问答文章4001 问答文章4501 问答文章5001 问答文章5501 问答文章6001 问答文章6501 问答文章7001 问答文章7501 问答文章8001 问答文章8501 问答文章9001 问答文章9501
你好,欢迎来到懂视!登录注册
当前位置: 首页 - 正文

求一段excel代码。批量提取多个excel工作簿中指定字段的数据,删除其 ...

发布网友 发布时间:2024-02-05 09:36

我来回答

2个回答

热心网友 时间:2024-02-29 09:08

你好!楼主想要的功能,可以通过VBA程序代码实现,其程序代码如下:(写代码不易,望笑纳)

Sub ChangeFile()
Dim fs, fo, fi, fil, str, na, ty, k, k1, k2, k3, k4, k5, k6, k7, arr1, arr2, xls, way
On Error Resume Next                   '忽略运行过程中可能出现的错误
Application.DisplayAlerts = False      '关闭报警提示
Application.ScreenUpdating = False     '关闭屏幕更新
way = "D:\ABCD\"                       '文件路径(文件夹)
arr1 = Array(".xls", ".xlsx", ".xlsm") '文件类型合集
arr2 = Array("交易账卡号", "交易户名", "交易日期", "交易金额", "收付标志", "对手账号", "对手户名", "对手开户银行", "摘要说明")
Set fs = CreateObject("Scripting.FileSystemObject")  '创建并返回对计算机系统文件的访问
Set fo = fs.Getfolder(way)                           '定义文件夹,“ABCD”为D盘下边的文件夹
Set fi = fo.Files                                    '定义文件夹下边所有文件集
For Each fil In fi                     '获取文件夹里面所有的文件
  na = fil.Name                        '获取文件名称
  pa = fil.Path                        '文件路径
  k1 = 0                               '每执行1行则初始化一次
  k2 = 0
    Do
     k2 = k2 + 1
     k = k1                            'k用来存放上次k1的值
     k1 = InStr(k1 + 1, na, ".")       'k1为“.”所在的位置
      If k1 = 0 And k <> 0 Then        '如果"."为文件后缀名的点
       str = Mid(na, 1, k - 1)         '截取文件名(不含文件类型)
       ty = Right(na, Len(na) - k + 1) '从右侧截文件类型
       Exit Do                         '退出Do循环
      Else
      If k1 = 0 And k = 0 Then          '如果没有文件后缀名,则
       str = na
       ty = ""
       Exit Do
      End If
      End If
      If k2 = 1000 Then                 '如果do循环超过1000次则强行退出
       Exit Do
      End If
     Loop
     
    For Each xls In arr1                   '对每个文件类型进行判断
     If xls = ty Then                      '判断后缀名是否Excel文件
     Workbooks.Open (pa)                   '打开文件
     For Each sh In Workbooks(na).Sheets   '对工作薄里面的每一个工作表进行扫描
      k3 = Application.WorksheetFunction.CountIf(sh.Range("A1:F10"), "")  '获取工作表里面空白单元格的个数
      If k3 > 20 Then   '此区域内空白单元格的个数超过20个,则此工作表是空白
       sh.Delete        '删除空白工作表
      Else              '否则
        For Each Rng In sh.Range("A1:Z1")        '对第一行A1:Z1单元格逐一判断
          If UBound(Filter(arr2, Rng)) < 0 Then  '如果此单元格不含关键字符(需要留下的),则
          sh.Columns(Rng.Column).Delete          '删除此列
          End If
        Next
        For Each Rng In sh.Range("A1:Z1")
         If Rng = "收付标志" Then                '获取关键字符所在的列
           k5 = Rng.Column
         End If
        If Rng = "交易金额" Then
           k6 = Rng.Column
         End If
         If Rng = "交易日期" Then
           k7 = Rng.Column
         End If
        Next

          For h = 2 To 100000                '对10万个单元格进行逐一扫描,可根据实际情况进行修改
           If sh.Cells(h, k5) = "进" Then    '如果含有关键字符,则填充相应的颜色
            sh.Range(sh.Cells(h, "A"), sh.Cells(h, "I")).Interior.Color = RGB(100, 255, 100)
           End If
           If sh.Cells(h, k5) = "出" Then
            sh.Range(sh.Cells(h, "A"), sh.Cells(h, "I")).Interior.Color = RGB(255, 100, 100)
            sh.Cells(h, k6) = -1 * sh.Cells(h, k6).Value
           End If
          Next
          With Windows(na)   '冻结工作表里面的首行
           .SplitColumn = 0
           .SplitRow = 1
           .FreezePanes = True
          End With
            sh.Sort.SortFields.Clear   '以下为按照日期进行排序,10万行
            sh.Sort.SortFields.Add Key:=Range(sh.Cells(2, k7), sh.Cells(100000, k7)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
              With sh.Sort
                .SetRange Range("A2:M100000")
                .Header = xlGuess
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
              End With
            sh.Range(sh.Cells(2, k6), sh.Cells(100000, k6)).NumberFormatLocal = "#,##0.00_ "   '交易金额那一列设置成所需的格式
            sh.Columns("A:Z").EntireColumn.AutoFit     'A:Z列自动调整列宽
        End If
     Next
    End If
  Next
    NewName = str & "_整理版" & ty                  '新工作薄的名称
    Workbooks(na).SaveAs Filename:=way & NewName    '新工作薄另存
    Workbooks(NewName).Close                        '新工作薄关闭
Next

Application.DisplayAlerts = True
Application.ScreenUpdating = True    '恢复屏幕更新
MsgBox "所有文件已经处理完成!"
End Sub

据楼主给出的附件,其修改之后的VBA程序代码如下:(源文件放在D盘的ABCD文件夹里面,后面可以在程序里面修改路径,VBA程序代码可以在任意的Excel工作薄里面的VBA程序模块里面运行)

Sub ChangeFile()
Dim fs, fo, fi, fil, str, na, ty, h, k, k1, k2, k3, k4, k5, k6, k7, k8, k9, arr1, arr2, xls, way, Rng
On Error Resume Next                   '忽略运行过程中可能出现的错误
Application.DisplayAlerts = False      '关闭报警提示
Application.ScreenUpdating = False     '关闭屏幕更新
way = "D:\ABCD\"                       '要修改的文件路径(文件夹里面)
arr1 = Array(".xls", ".xlsx", ".xlsm") '文件类型合集
arr2 = Array("交易账卡号", "交易户名", "交易日期", "交易金额", "收付标志", "对手账号", "对手户名", "对手开户银行", "摘要说明")
Set fs = CreateObject("Scripting.FileSystemObject")  '创建并返回对计算机系统文件的访问
Set fo = fs.Getfolder(way)                           '定义文件夹,“ABCD”为D盘下边的文件夹
Set fi = fo.Files                                    '定义文件夹下边所有文件集
For Each fil In fi                     '获取文件夹里面所有的文件
  na = fil.Name                        '获取文件名称
  pa = fil.Path                        '文件路径
  k1 = 0                               '每执行1行则初始化一次
  k2 = 0
    Do
     k2 = k2 + 1
     k = k1                            'k用来存放上次k1的值
     k1 = InStr(k1 + 1, na, ".")       'k1为“.”所在的位置
      If k1 = 0 And k <> 0 Then        '如果"."为文件后缀名的点
       str = Mid(na, 1, k - 1)         '截取文件名(不含文件类型)
       ty = Right(na, Len(na) - k + 1) '从右侧截文件类型
       Exit Do                         '退出Do循环
      Else
      If k1 = 0 And k = 0 Then          '如果没有文件后缀名,则
       str = na
       ty = ""
       Exit Do
      End If
      End If
      If k2 = 1000 Then                 '如果do循环超过1000次则强行退出
       Exit Do
      End If
     Loop
     
    For Each xls In arr1                   '对每个文件类型进行判断
     If xls = ty Then                      '判断后缀名是否Excel文件
     Workbooks.Open (pa)                   '打开文件
     For Each sh In Workbooks(na).Sheets   '对工作薄里面的每一个工作表进行扫描
      k3 = Application.WorksheetFunction.CountIf(sh.Range("A1:F10"), "")  '获取工作表里面空白单元格的个数
      If k3 > 20 Then   '此区域内空白单元格的个数超过20个,则此工作表是空白
       sh.Delete        '删除空白工作表
      Else              '否则
         k9 = 0         '每个工作表执行时都重置0
         For k8 = 1 To 60  '执行60次循环
          If UBound(Filter(arr2, sh.Cells(1, k8 - k9))) < 0 Then '如果此单元格不含关键字符(不是需要留下的),则
          sh.Columns(sh.Cells(1, k8 - k9).Column).Delete         '删除此列
          k9 = k9 + 1  '被删除的次数累计1
          End If
        Next
        For Each Rng In sh.Range("A1:Z1")
         If Rng = "收付标志" Then                '获取关键字符所在的列
           k5 = Rng.Column
         End If
        If Rng = "交易金额" Then
           k6 = Rng.Column
        End If
         If Rng = "交易日期" Then
           k7 = Rng.Column
         End If
        Next

          For h = 2 To 100000                '对10万个单元格进行逐一扫描,可根据实际情况进行修改
           If sh.Cells(h, k5) = "进" Then    '如果含有关键字符,则填充相应的颜色
            sh.Range(sh.Cells(h, "A"), sh.Cells(h, "I")).Interior.Color = RGB(100, 255, 100)  '填充的颜色到I列
            sh.Cells(h, k6) = 1 * sh.Cells(h, k6).Value  '转换成数值
           End If
           If sh.Cells(h, k5) = "出" Then
            sh.Range(sh.Cells(h, "A"), sh.Cells(h, "I")).Interior.Color = RGB(255, 100, 100)
            sh.Cells(h, k6) = -1 * sh.Cells(h, k6).Value
           End If
          Next
          With Windows(na)   '冻结工作表里面的首行
           .SplitColumn = 0
           .SplitRow = 1
           .FreezePanes = True
          End With
            sh.Sort.SortFields.Clear   '以下为按照日期进行排序,10万行
            sh.Sort.SortFields.Add Key:=Range(sh.Cells(2, k7), sh.Cells(100000, k7)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
              With sh.Sort
                .SetRange Range("A2:M100000")
                .Header = xlGuess
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
              End With
            sh.Range(sh.Cells(2, k6), sh.Cells(100000, k6)).NumberFormatLocal = "#,##0.00_ "   '交易金额那一列设置成所需的格式
            sh.Columns("A:Z").EntireColumn.AutoFit     'A:Z列自动调整列宽
        End If
     Next
    End If
  Next
    NewName = str & "_整理版" & ty                  '新工作薄的名称
    Workbooks(na).SaveAs Filename:=way & NewName    '新工作薄另存(路径可自行修改)
    Workbooks(NewName).Close                        '新工作薄关闭
Next

Application.DisplayAlerts = True
Application.ScreenUpdating = True    '恢复屏幕更新
MsgBox "所有文件已经处理完成!"
End Sub


【注】部分代码引用自百度经验:《使用VBA批量重命名文件》

热心网友 时间:2024-02-29 09:12

这个需要文档吧,不然不好写
声明:本网页内容为用户发布,旨在传播知识,不代表本网认同其观点,若有侵权等问题请及时与本网联系,我们将在第一时间删除处理。
E-MAIL:11247931@qq.com
网上到底有没有钢《铁侠侠3》的高清完整版呀? 有木有下载[钢铁侠3BD1280真正高清收藏版][161电影网种子的网址_百度知 ... 苏州甪直怎样坐车去上海虹桥?要快的! 从吴江自驾去上海虹桥机场T2航站楼怎么走?大约要多久?有停车场不?第一... 从甪直开车到上海虹桥机场T1航站楼怎么走? 甪直到虹桥机场多长时间? 柴油暖风机多少钱一台_柴油暖风机什么牌子好 国务院关于加快发展现代保险服务业的若干意见 国发2019 29号_百度知 ... 八万的那个夏天是什么意思? 北京BW007有什么安全配置 急急急! 给我取一个干洗店的名子! 要求:三个字的!要带福字的! 不带也... 孕期不适,你真的了解吗? 改个有意义的id 太白湖附属医院坐几路公交车 《再见爱人》中哪对夫妻让你感触最深? 一天跑3次1小时左右的慢跑,对身体有害吗? 微信手机号在24小时内,已绑定两个,已达到限制,不能在绑定其他微信... 您的手机号在最近24小时内绑定过三个,已达到限制,...24小时后... 微信手机号在24小时内,已绑定两个,已达到限制,不能在绑定其他微信... 海淀区高三期末考试安排 好寓意的id 2013年阳历4月出生的,父姓张母姓裴起什么名字好(男女各取一个) ...之前的那个手机号还可以重新申一个吗? 修改未满一年怎么修改 海口装修比较好的小学 经典动漫哆啦A梦的主题曲粤语版《哆啦A梦》,满满的童年回忆 无线路由器设置好了,笔记本有线无线都可以通过路由器上网。台式机不能... 下列关于情绪和情感的论述,正确的是() 关于微信绑定上限的问题:你的手机号在最近24小时内已绑定过3个... 换绑定手机号,那原来的手机号能重新申请微信吗 十八反歌拼音怎样写 宁夏吴忠住宿推荐 电脑一键锁屏快捷键是什么? 未满一年可以强制改吗 黄米面麻糖怎么做 传动系统在工作中有哪些优缺点? 为什么每周二下午(除法定节假日外)没有电视节目? 微信手机号在24小时内,已绑定两个,已达到限制,不能在绑定其他微信... 未满一年怎么改第二次 哆啦A梦新粤语主题曲叫什么名字哇.. 一年内能改第二次吗? 什么是SCI、EI?这些论文有多少可以转化为生产力或者能产业化的?_百度... 请教下如何用EXCEL进行按照交易地点统计不同区间的计数和求和_百度知 ... 未满一年可以强制改吗 同一个手机号怎么找回原来的? 改错了未满一年怎么改回来 什么是“半包”结构的字? 亲子旅游自由行线路:精彩的父子母女欢乐时光 和父母旅游的好处都有哪些啊? 去汉中石门栈道风景区游玩,怎样规划行程比较好?
  • 焦点

最新推荐

猜你喜欢

热门推荐