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

Question

求万能的大神帮我写一段excel代码（使用的版本为excel2019）。现在有多个工作簿，每个工作簿中含有3张sheet，其中2张sheet为空表，1张sheet中有数据并包含有多个字段，需要如下效果：1.删除工作簿中的空表；2.只需要保留以下几个字段的所有数据：交易账卡号、交易户名、交易日期、交易金额、收付标志、对手账号、对手户名、对手开户银行、摘要说明；删除其他字段；3.将“收付标志”中数值为“进”的行颜色填充为（255,100,100），数值为“出”的行颜色填充为（100,255,100）；4. 将“收付标志”数值为“出”的所有行中的“交易金额”字段全部乘以-1；5.冻结首行；6.保留数据源表并将源表命名为“源数据”，提取出的含特定字段的新表命名为“整理版”， 7.自动工作表调整列宽；8. “整理版”表中按“交易日期”字段升序排列；9.“交易金额”字段中的内容转换为数值格式，最好再以千分位表示（因为源数据经常是带有绿色小三角，需要手工转换为数值）上述7项需要的结果中，1-4项为主，5-9项如果代码难得写就算了，excel有相应的功能，只是经常需要分析大量的工作簿，如果大神能一次性帮我写上去更更好啊。现附源表和效果表各一张如下：

Answer 1

你好！楼主想要的功能，可以通过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批量重命名文件》

Answer 2

这个需要文档吧，不然不好写