同目录下电子表格数据汇总（VBA代码）_仲勇_QQ_171944653

http://blog.sina.com.cn/u/2027461704

首页博文目录关于我

个人资料

微博

加好友发纸条

写留言加关注

博客等级：
博客积分：

博客访问：
关注人气：
获赠金笔：0支
赠出金笔：0支
荣誉徽章：

正文字体大小：大中小

同目录下电子表格数据汇总（VBA代码）

(2013-03-05 10:40:32)

标签：

it

vba

合并

主程序代码：

Sub ins_sheet()

'获取汇总后的xls文件的路径

Dim patch As String

patch = GetPatch()

If patch = "" Then

Exit Sub

End If

'获取文件夹对象

Dim myfilesystem As Object

Set myfilesystem = _

CreateObject("Scripting.FileSystemObject")

Dim aimFolder As Folder

Set aimFolder = myfilesystem.GetFolder(patch)

'复制指定文件夹下的xls文件

For Each one In aimFolder.Files

If one.Type = "Microsoft Excel 工作表" Then

MyCopy (one.path)

End If

Next one

End Sub

'弹出对话框获取路径的GetPatch过程代码

Function GetPatch() As String

'调用文件选取对话框

Dim fd As FileDialog

Set fd = Application.FileDialog(msoFileDialogFolderPicker)

Dim result As Integer

With fd

.AllowMultiSelect = False

'显示对话框

result = .Show()

If result <> 0 Then

'返回用户选择的路径

GetPatch = fd.SelectedItems(1)

Else

GetPatch = ""

End If

End With

Set fd = Nothing

End Function

'将指定路径下的工作簿中的所有工作表复制到当前工作簿中的过程

Sub MyCopy(path As String)

Application.ScreenUpdating = False

Application.DisplayAlert = False

'获取目标工作簿

On Error GoTo err

Workbooks.Open (path)

Dim source As Workbook

Set source = ActiveWorkbook

'循环访问该工作簿的所有工作表

Dim index As Integer

For index = 1 To source.Worksheets.Count

'复制该工作表到当前工作簿中

source.Worksheets(index).Copy Before:=ThisWorkbook.Worksheets(1)

'用各人的姓名作为工作表名

ThisWorkbook.Worksheets(1).Name = Left(source.Name, Len(source.Name) - 4)

Next index

source.Close

Application.ScreenUpdating = True

Application.DisplayAlert = True

Exit Sub

err:

End Sub

'以记录方式合并工作表数据到同一工作表中。

Sub hbjl()

Dim i, j As Integer, icount As Integer

'统计需要合并的工作表最大index

icount = Worksheets.Count - 1

Worksheets("合并为记录").Select

i = 3

For j = 2 To icount

Worksheets("合并为记录").Cells(i, 1) = Worksheets(j).Cells(2, 2)

Worksheets("合并为记录").Cells(i, 2) = Worksheets(j).Cells(2, 4)

Worksheets("合并为记录").Cells(i, 3) = Worksheets(j).Cells(2, 6)

Worksheets("合并为记录").Cells(i, 4) = Worksheets(j).Cells(3, 2)

Worksheets("合并为记录").Cells(i, 5) = Worksheets(j).Cells(3, 4)

Worksheets("合并为记录").Cells(i, 6) = Worksheets(j).Cells(3, 6)

Worksheets("合并为记录").Cells(i, 7) = Worksheets(j).Cells(4, 2)

Worksheets("合并为记录").Cells(i, 8) = Worksheets(j).Cells(4, 4)

Worksheets("合并为记录").Cells(i, 9) = Worksheets(j).Cells(4, 6)

Worksheets("合并为记录").Cells(i, 10) = Worksheets(j).Cells(5, 2)

Worksheets("合并为记录").Cells(i, 11) = Worksheets(j).Cells(7, 1)

Worksheets("合并为记录").Cells(i, 12) = Worksheets(j).Cells(9, 1)

i = i + 1

Next j

'统计汇总结果

MsgBox "一共成功合并了" + Str(icount) + "个教工的表格数据！"

End Sub

阅读┊ 收藏 ┊ 喜欢 ▼ ┊打印┊举报/Report

前一篇：分类数据选择录入我用Excel

后一篇：工作表的拆分与目录创建（代码）

新浪BLOG意见反馈留言板　欢迎批评指正