vba工作表如何合并（VBSVBA多表合并）

工作当中，有时候需要将多个excel合并成一个表格，如果表数量少手工就可以合并，遇到有大量表格就必须利用VBA代码了，但很多童鞋使用的是WPS，对VBA的支持不是很友好，推荐使用vbs脚本，以下为代码，将以下代码复制到txt文件里，然后把txt文件后缀改为vbs,双击即可运行，我来为大家科普一下关于vba工作表如何合并?下面希望有你要的答案，我们一起来看看吧!

vba工作表如何合并

工作当中，有时候需要将多个excel合并成一个表格，如果表数量少手工就可以合并，遇到有大量表格就必须利用VBA代码了，但很多童鞋使用的是WPS，对VBA的支持不是很友好，推荐使用vbs脚本，以下为代码，将以下代码复制到txt文件里，然后把txt文件后缀改为vbs,双击即可运行

dim oExcel

Set oExcel=CreateObject("Excel.Application")

file_selected= oexcel.getopenfilename ("打开表格文件*.xls;*.xlsx;*.xlsm ,*.xls;*.xlsx;*.xlsm", filterindex, "打开表格", buttontext, true)

if isarray(file_selected) Then

call heBing(file_selected)

end if

set oExcel=Nothing

wscript.quit

'-----------------以下未生存汇总表过程------------------------

sub heBing(arExport)

dim dict

set dict =createobject("scripting.dictionary")

for ai = 1 to UBound(arExport)

call openworkbook(arExport(ai),dict)

next

if dict.count>1 then

call dicZhuanArr(dict)

Else

wscript.echo "没有数据"

end if

set dict=Nothing

end sub

sub openWorkbook(path,dict)

set workbook = oExcel.workbooks.open(path)

call getsystemexcel(workbook,dict)

workbook.close

set workbook=Nothing

end sub

Sub getSystemExcel(wb,dict)

arr = wb.sheets(1).UsedRange

row = 1'默认表头从第一行开始

call head(arr,row,dict)

for a = row 1 to UBound(arr,1)

str = ""

for aa = 1 to UBound(arr,2)

str = str&"&&"&arr(a,aa)

next

str = Left(wb.name,len(wb.name)-5)&str'保留字段，表格名称，便于查错

dict.item(str)=dict.item(str) 1

next

End Sub

' 表头

Sub head(arr,row,dict)

' '表头放在字典首行

for aa = 1 to UBound(arr,2)

str = str&"&&"&arr(row,aa)

next

str = "来源"&str'保留字段表头

dict.item(str)=dict.item(str) 1

end sub

sub dicZhuanArr(dict)

dim newArr()

arr = dict.keys

Redim newArr(UBound(arr),100)

ar = Split(arr(0),"&&")

for i = 0 to UBound(arr)

for a = 0 to UBound(ar)

newArr(i,a)=Split(arr(i),"&&")(a)

next

Next

call addWorkbook(newArr)

end sub

Sub addWorkbook(ar)

Set wb = oExcel.Workbooks.Add

n = createobject("Scripting.FileSystemObject").GetFile(Wscript.ScriptFullName).ParentFolder.Path&"\"

Set wt = wb.Sheets(1)

With wt

.Range("a1").Resize(UBound(ar, 1) 1, UBound(ar, 2)) = ar

.Name = "明细"

End With

wb.SaveAs n& FormatDate(Now(),"YYYY-MM-DD hh mm ss") & ".xlsx"

wb.Close False

Set wb = nothing

End Sub

,