求一段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批量重命名文件》
这个需要文档吧，不然不好写
如何在c#下读取EXCEl表格中的数据,最好写一段代码
（转）创建、打开、读取、写入、保存的一般性代码：using System;using System.Reflection; \/\/ 引用这个才能使用Missing字段 namespace CExcel1 { class Class1 { [STAThread]static void Main(string[] args){ \/\/创建Application对象 Excel.Application xApp=new Excel.ApplicationClass();xApp.Visible=...
一段EXCEL VBA代码不明白,请高手指教
代码的功能是将当前的偶数的sheet复制到前一个奇数的sheet，然后删除偶数的sheet，所以你从现象上看，好像是两个sheet的合并。注释如下：Sub 按钮1_单击()'关闭屏幕更新，如果设置成true，那么会看到excel的值一个格子一个格子的填充。Application.ScreenUpdating = False '关闭显示警告信息框 Application....
请EXCEL VBA高手 ,帮忙解释一下 下面这段代码,具体是什么意思?
Sub save() '定义过程名；Dim ar, ix As Integer '定义变量ar和ix为整型变量；If [B2] = "甲" Then ix = 2: X = Sheets(ix).Range("A65536").End(xlUp).Row'Range("A65536").End(xlUp).Row意为当活动单元格为A65536（即A列最下面一个单元格）时，按一次Ctrl+向上键后，新...
求一段excel vba循环代码
楼主，您看看这段代码, 代码中变化的位置有两个地方 1. Start:=X 2. .Size =X+8 所以先定义一个变量来代替上述X位置， 然后再用一个循环使变量从1变化到8并变成相关设定动作即可.如下:Dim i As Integer For i=8 to 16 then With ActiveCell.Characters(Start:=i, Length:=1).Font .Name...
受累帮我解释一下这段excel的vba代码吧,谢谢您了,越详细越好,用\/\/在...
Cells(ks + 1, 1).Resize(js - ks, 3).Delete shift:=xlUp '判断条件成立则删除对应的区域，（此代码可能有问题哦），目的应该是清除小计之前的明细区域 Cells(ks, 4).Resize(js - ks, 8).Delete shift:=xlUp '此行也是删除区域的代码，（可能有问题分析下来）End If Next Applicatio...
有一段EXCEL VBA代码,部分语句看不太懂,买的书上也没有找到。求解释_百...
--- brr(1, m) = arr(i, 1): brr(2, m) = arr(i, 2) 这句中的冒号 就是把本来要写在两行的代码写在一行的做法，等价于 brr(1, m) = arr(i, 1)brr(2, m) = arr(i, 2)这样就好理解了哦，就是给brr 数组赋值，赋的是arr的数据 --- [a1].CurrentRegion.Offset(1).C...
谁能帮我写段Excel VBA代码达到将表1上的数据统计到如表2格式中,在这...
表1 的标题行，要放在 第一行 其实可以用数据透视表来做，也一样 代码 是下面的：Sub 统计()Dim d1 As Object, d2 As Object, d3 As Object, rng As Range, arr, arr1 Set d1 = CreateObject("Scripting.Dictionary")Set d2 = CreateObject("Scripting.Dictionary")Set d3 = ...
求写excel vba中的一段代码
Integer是整数型，范围：-32,768 到 32,767 Long 长整数型，范围：-2,147,483,648 到 2,147,483,647 把Dim i As Integer改为Dim i As Long即可。【下面的代码已更新】：Sub JiSuan() b = [A2] e = [B2] g = [C2] r = [D65536].End(3).Row + 1 '赋值r=D列...
excel求编一段VBA代码
将相关信息存入二维数组arr（n,m）（n表示sheet数，m表示该sheet下b列含值行数），最后将数组导出就可以了,最后张sheet是你的汇总表 dim arr()for n = 1 to thisworkbook.worksheets.count -1 for m = 1 to thisworkbook.worksheets(n).userange.rows.count arr(n,m) = 。。。不明白“A...
在Excel VBA写一段代码。根据当前单元格输入内容。提取数据列包含该单...
Sub parse_data()Dim lr As Long Dim ws As Worksheet Dim vcol, i As Integer Dim icol As Long Dim myarr As Variant Dim title As String Dim titlerow As Integer vcol = 1 Set ws = Sheets("Sheet1")lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row title = "A1:C1"ti...
班官复方： EXCEL批处理问题:如何批量提取多个excel文件里sheet1的第一行的方法.如下参考:1.如下图所示,我们在TXT文本中有一些数据内容,希望将它们传输到excel电子表格中.我们打开excel表格.2.在表上方的菜单工具栏中有一个data选项,...
麻山区19490917420： 如何提取一个EXCEL表中的多个工作薄数据? - ？
班官复方： 选择Sheet1,鼠标右击sheet1的标签,点【查看代码】,在代码窗口粘贴下面的代码: Sub ouyangff() t = ActiveWorkbook.Worksheets.Count For i = 1 To tCells(i + 100, 1) = Sheets(i).NameCells(i + 100, 2) = Sheets(i).[i40]Cells(i + 100, 3) = ...
麻山区19490917420： excel 批量提取多个不同表的数据 例如文件1的A列是很多名字,B列需要批量输入电话号码,在某个文件夹里有 - ？
班官复方： 在B1输入公式:=＂='D:\[＂&A1&＂.xls]Sheet3'!$F$4＂下拉.然后复制整列,再点右键--选择性粘贴--数值,然后选择整列,数据--分列--下一步--点选常规,确定.
麻山区19490917420： excel自动取多个文件中固定位置的值 - ？
班官复方： 把所有文件放到同一个文件夹 新建一个文件 汇总 打开 汇总表 和你要计算的表 比如 beijing 汇总表A1=[BEIJING.xls]Sheet1'!A1+........+[shanghai.xls]Sheet1'!A1 这样就可以计算了 或者你把所有的表 导入同一个工作簿 计算起来就更快了
麻山区19490917420： excel求教一段循环提取数据的代码 - ？
班官复方： n=1 for r=1 to range(＂a65536＂).end(xlup).row cells(n,2)=cells(r,1) n=n+1 next
麻山区19490917420： excel中第一列A中有A1到A100共100个数据,怎样提取A1到A10,A2到A11,...,每次提取10个数据? - ？
班官复方： 在C1输入2, 在B1输入=INDIRECT(＂A＂&ROW()+$C$1-1) 往下拖到B10就可以了 C1单元格的数字表示从第几行开始,往下10个数据 ,这个数字根据需要更改
麻山区19490917420： EXCEL提取文件夹内多个文件的同一单元格数据 - ？
班官复方： 既然已经找到取得数据的代码,那么这就只写取得公式的语句吧: thisworkbook.sheets(1).range(＂A＂ &).Formula=变量文件名.变量工作表名.range(＂b2＂).Formula C9同理
麻山区19490917420： EXCEL采用if命令提取多个符合条件的字段？
班官复方： 这种问题If 是实现不了的 如果你需要, 可以Q我 1052974911 给你用VBA 搞定 ======== Sub tiqu() Worksheets(＂采购汇总表＂).Range(＂B2:C10000＂).ClearContents For i = 2 To Worksheets(＂采购汇总表＂).Range(＂D65536＂).End(...
麻山区19490917420： Excel单元格部分内容批量提取?比如单元格内容格式是 编码bw123456789 号码:123 - ？
班官复方： 长度是一样的额么?都是9位数么?如果是,可以考虑利用right函数 如果原数据是在A1中=right(A1,12) 就可以了.
麻山区19490917420： Excel 请问如何快速提取多个工作表中同一列数据 - ？
班官复方： 用公式啊把问题作为内容(邮件主题一定要包含“excel”,本人以此为依据辨别非垃圾邮件,以免误删),excel样表文件(把现状和目标效果表示出来)作为附件发来看下 yqch134@163.com
