求一段excel代码。批量提取多个excel工作簿中指定字段的数据，删除其他字段
你好！楼主想要的功能，可以通过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批量重命名文件》