[求助]如何批量向多个excel文件中添加内容

lzldz

附件中是一个事例,里面共有四个文件,其中"Spring","Summer"和"autumn"是源文件,"汇总"是目标文件


问题:在"汇总"这个文件中已经能够实现将上述三个源文件同时合并到一个excel里,那么能否在汇总的同时分别向目标文件中添加一列(在Website列边上),该列内容为对应的文件的文件名?


即最后的绘总文件为下面的格式:





























Exhibitor


Address


…


Email


Web Site


aututmn





Consensus Systems Technologies


17 Miller AvePO Box 517





rsj@consystec.com





aututmn





Core Tec Communications, LLC


8611 Weston Rd.Unit 16





rocco.magnotta@coretec.com


www.gocoretec.com


aututmn





Cornet Technology, Inc.


6800 Versar CenterSuite 215





rdagostino@cornet.com


www.cornet.com/vc


aututmn





Daktronics, Inc.


331 32nd AvePO Box 5128





mwatkin@daktronics.com


www.daktronics.com


aututmn





Exhibitor


Address





Email


Web Site


spring





3M Intelligent Transportation Systems


3M CenterBuilding 225-5S-08





mllozier@mmm.com


www.3M.com/tss


spring





Access Technology Group</T

业余爱好者

OFFICE不是万能的

没有OFFICE是万万不能的



[em01]

lzldz

呵呵,谢谢关注,不过已经自己解决了,下面是源码,其中有一部分是论坛其他高手编的,有一部分是自己加进去的,算是回馈给个位朋友吧

Private Sub CommandButton1_Click()
    Dim Twb As Workbook, Wb As Workbook
    Dim rng As Range, rng2 As Range
    Dim s
    Dim R As Double, C As Double
    Dim T As String
     
   
    Application.ScreenUpdating = False
    Set Twb = ThisWorkbook
   
    Cells.ClearContents '清除当前表的内容
    With Application.FileSearch '查找
        .LookIn = Twb.Path '范围为此目录下
        .Filename = "*.xls" '查找所有的xls文件
        .Execute msoSortByFileName '执行查找过程，并且将查询结果按文件名排序
        
        For Each s In .FoundFiles '在每一个查找到的结果里
            If s <> Twb.FullName Then '假如它不是当前工作簿
                Set Wb = Workbooks.Open(s) '打开它
                Set rng = Range("a65536").End(xlUp).Offset(1, 0) '设置变量rng为最后一行的下一行
                R = Wb.Sheets(1).UsedRange.End(xlDown).Row '当前工作簿已用行数
                C = Wb.Sheets(1).UsedRange.End(xlToRight).Column + 1 '当前工作簿已用行数+1
                T = "*-FileNme-*" '将字符常量赋给T
                Wb.Sheets(1).Cells(1, C).Value = T '将当前工作部最后一列右边第一列第一个单元格赋值T
                Wb.Sheets(1).Range(Wb.Sheets(1).Cells(2, C), Wb.Sheets(1).Cells(R, C)).Value = left(Wb.Name,len(wb.name)-4) '为每条信息标注其所在的文件文件名
                Wb.Sheets(1).UsedRange.Copy rng '复制新打开的工作簿的第一个工作表的已用区域到rng
                Wb.Close False ' 不保存就关闭这个打开的工作簿
            End If
        Next
    End With
   
    Application.ScreenUpdating = True
End Sub

[此贴子已经被作者于2007-6-26 15:35:52编辑过]