注册 登录  
 加关注
   显示下一条  |  关闭
温馨提示!由于新浪微博认证机制调整,您的新浪微博帐号绑定已过期,请重新绑定!立即重新绑定新浪微博》  |  关闭

奕克

爱家人爱工作爱生活

 
 
 

日志

 
 

一个合并同一目录下所有excel数据的vbs小程序  

2012-09-21 11:13:50|  分类: office |  标签: |举报 |字号 订阅

  下载LOFTER 我的照片书  |
     前几天一个同事让帮忙写个小程序,把同一目录下所有excel文件的第一个工作表的数据合并成一个excel,最好能通过各自的文件名对合并后的数据进行区分。
     所以今天动手写了写,一劳永逸,办公任务,学点程序还是很有用的。。。
      合并的示例代码在(http://dl.vmall.com/c0h3r6iey4 )
     也可以自己在要合并的目录下新建文本文档,拷入如下代码,另存为扩展名为.vbs的文件,点击运行,生成的合并excel名字为“合并.xls“,最后一列为来数据自哪个excel文件:

Set WshShell = WScript.CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
set xlsapp = CreateObject("excel.Application")
xlsapp.visible=true
set hb=xlsapp.workbooks.add
hb.saveas(WshShell.CurrentDirectory & "\合并.xls")
Set myfolder = fso.GetFolder(WshShell.CurrentDirectory)
index=1
For Each myfile In myfolder.Files
  if InStr(myfile.name,".xls")<>0 and InStr(myfile.name,"合并.xls")=0 and InStr(myfile.name,"$")=0  then
   set temp=xlsapp.workbooks.open(WshShell.CurrentDirectory & "\" & myfile.name)
   temp.Worksheets(1).Rows("1:" & temp.Worksheets(1).UsedRange.Rows.Count).Copy
   hb.Worksheets(1).Rows(index).PasteSpecial
   fnl=Len(myfile.Name)
   For i = index To hb.Worksheets(1).UsedRange.Rows.Count
      hb.Worksheets(1).Cells(i,temp.Worksheets(1).UsedRange.Columns.Count+1).Value = Left(myfile.Name,fnl-4)
   Next
   hb.Save
   index=hb.Worksheets(1).UsedRange.Rows.Count+1
   temp.close
   set temp=Nothing
  end if
next
hb.worksheets(1).columns.autofit
hb.save
hb.close
set hb=nothing
set myfolder=nothing
xlsapp.quit
Set xlsapp= Nothing
Set fso = Nothing
Set wshell = Nothing 
MsgBox "OK,请打开合并.xls"

同事反映上面的程序合并后,每个文件的表头一列都重复了,下面的程序运行时,输入表头占用的行数,就只保留第一个文件的表头:

x=inputbox("请输入每个文件表头所占的行数:")
Set WshShell = WScript.CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
set xlsapp = CreateObject("excel.Application")
xlsapp.visible=true
set hb=xlsapp.workbooks.add
hb.saveas(WshShell.CurrentDirectory & "\合并.xls")
Set myfolder = fso.GetFolder(WshShell.CurrentDirectory)
index=1
For Each myfile In myfolder.Files
  if InStr(myfile.name,".xls")<>0 and InStr(myfile.name,"合并.xls")=0 and InStr(myfile.name,"$")=0  then
   set temp=xlsapp.workbooks.open(WshShell.CurrentDirectory & "\" & myfile.name)
   if index=1 then
     temp.Worksheets(1).Rows("1:" & temp.Worksheets(1).UsedRange.Rows.Count).Copy
   else
     temp.Worksheets(1).Rows((x+1) & ":" & temp.Worksheets(1).UsedRange.Rows.Count).Copy
   end if
   hb.Worksheets(1).Rows(index).PasteSpecial
   fnl=Len(myfile.Name)
   For i = index To hb.Worksheets(1).UsedRange.Rows.Count
      hb.Worksheets(1).Cells(i,temp.Worksheets(1).UsedRange.Columns.Count+1).Value = Left(myfile.Name,fnl-4)
   Next
   hb.Save
   index=hb.Worksheets(1).UsedRange.Rows.Count+1
   temp.close
   set temp=Nothing
  end if
next
hb.worksheets(1).columns.autofit
hb.save
hb.close
set hb=nothing
set myfolder=nothing
xlsapp.quit
Set xlsapp= Nothing
Set fso = Nothing
Set wshell = Nothing 
MsgBox "OK,请打开合并.xls"
  评论这张
 
阅读(1387)| 评论(1)
推荐 转载

历史上的今天

在LOFTER的更多文章

评论

<#--最新日志,群博日志--> <#--推荐日志--> <#--引用记录--> <#--博主推荐--> <#--随机阅读--> <#--首页推荐--> <#--历史上的今天--> <#--被推荐日志--> <#--上一篇,下一篇--> <#-- 热度 --> <#-- 网易新闻广告 --> <#--右边模块结构--> <#--评论模块结构--> <#--引用模块结构--> <#--博主发起的投票-->
 
 
 
 
 
 
 
 
 
 
 
 
 
 

页脚

网易公司版权所有 ©1997-2017