我思集    管理页面    写新日志    退出


«April 2020»
1234
567891011
12131415161718
19202122232425
2627282930

公告
     我思故我在

──笛卡儿


我的分类(专题)

日志更新

最新评论

留言板

链接

Blog信息
blog名称:我思集
日志总数:38
评论数量:393
留言数量:-1
访问次数:587059
建立时间:2005年3月29日

MapsGoogle浏览




[软件心得]组合(合并)Excel文档
yth 发表于 2006-9-26 23:46:16
收到很多Excel文档,需要把它们组合在一起形成一张大表,然后才进行格式化。 由于文档格式有些差异,合并最好的办法只能是复制、粘贴,为提高效率,特编此VBA: Sub MergeWorkbooks()    Dim i As Long    Dim WB As Workbook    Dim currentWS As Worksheet    Set currentWS = ActiveSheet    Application.DisplayAlerts = False    With Application.FileDialog(msoFileDialogOpen)        .Filters.Clear        .Filters.Add "Excel", "*.xls", 1        .AllowMultiSelect = True        .Show        For i = 1 To .SelectedItems.Count            Set WB = Workbooks.Open(.SelectedItems(i))            MyUsedRange            Selection.Copy            currentWS.Activate            ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Select            Cells(Selection.Row + 1, 1).Select            ActiveSheet.Paste            WB.Close        Next i    End With    Application.DisplayAlerts = TrueEnd Sub Sub MyUsedRange()Dim ar As Range, r As Double, c As Integer, tr As Double, tc As IntegerDim ur As Range, fr As Double, fc As Integer, tfr As Double, tfc As Integer On Error Resume Next  fc = ActiveSheet.Columns.Count  fr = ActiveSheet.Rows.Count  Set ur = Union(ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants), _      ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas))  If Err.Number = 1004 Then      Err.Clear      Set ur = ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants)  End If  If Err.Number = 1004 Then      Err.Clear      Set ur = ActiveSheet.UsedRange.SpecialCells(xlCellTypeFormulas)  End If  If Err.Number = 0 Then      For Each ar In ur.Areas         tr = ar.Range("A1").Row + ar.Rows.Count - 1         tc = ar.Range("A1").Column + ar.Columns.Count - 1         If tc > c Then c = tc         If tr > r Then r = tr         tfr = ar.Range("A1").Row         tfc = ar.Range("A1").Column         If tfc < fc Then fc = tfc         If tfr < fr Then fr = tfr      Next      Range(Cells(fr, fc), Cells(r, c)).Select  ElseIf Err.Number = 1004 Then      Range("A1").Select  End IfEnd Sub 如此把选中文档(可以多个)的当前sheet拷贝到vba执行时的活动sheet中,并向下平铺。 MyUsedRange子程序摘自微软http://support.microsoft.com/default.aspx?scid=kb%3Bzh-cn%3B232094 感觉比Excel自带的UsedRange好用。


阅读全文(3211) | 回复(0) | 编辑 | 精华


发表评论:
昵称:
密码:
主页:
标题:
验证码:  (不区分大小写,请仔细填写,输错需重写评论内容!)



站点首页 | 联系我们 | 博客注册 | 博客登陆

Sponsored By W3CHINA
W3CHINA Blog 0.8 Processed in 0.015 second(s), page refreshed 144388149 times.
《全国人大常委会关于维护互联网安全的决定》  《计算机信息网络国际联网安全保护管理办法》
苏ICP备05006046号