请问合并在不同分文件夹的同名同格式文件的程序怎么编写呢？

KCFONG

太可怜了
从前的日子多悠闲

sunnystar

KCFONG 发表于 2012-8-31 20:27
太可怜了
从前的日子多悠闲

今天还加班了。
好在下周可以使用神器啦。
刚还试了下坛子里面的VBA模拟音乐播放器~很亮啊

jjmysjg

KCFONG 发表于 2012-8-30 04:18
Please test

KCFONG老师你好，运行后，出现提示，麻烦老师看看。

那谁谁

KCFONG
从不同文件夹中汇总到一个EXCEL v6.rar  试过了，能合并文件，但中间有报错Workbooks.Open nfile，
合并出的文件也打不开呀，用2003或2010版都打不开文件嘛
我有类似需求，请再帮看看
Sub 合并()
Application.DisplayAlerts = False
Set fs = CreateObject(Scripting.FileSystemObject)
Set f = fs.GetFolder(ThisWorkbook.Path)

    Set sf = f.SubFolders
    For Each f1 In sf
       For Each fff In f1.Files
         If fff.Name Like .xls Then
         nfilename = 合并 & Replace(fff.Name, xls, ) & xlsx '合并filename
         Else
         nfilename = 合并 & fff.Name '合并filename
         End If
         nfile = ThisWorkbook.Path &  & nfilename '合并file fullname
            If fs.fileexists(nfile) = False Then
               Workbooks.Add
               Sheets(1).Name = 合并
               ActiveWorkbook.SaveAs nfile
            Else
                 Workbooks.Open nfile
            End If
           
            Workbooks.Open fff  'source file
                er = [a65536].End(xlUp).Row
                ec = ActiveSheet.UsedRange.Columns.Count
                tr = Workbooks(nfilename).Sheets(合并).[b65536].End(xlUp).Row + 1 '合并filename
                If tr = 2 Then  'copy the title
                   tr = 1
                   ActiveSheet.Range(Cells(1, 1), Cells(1, ec)).Copy Workbooks(nfilename).Sheets(合并).Range(b1)
                   'Workbooks(nfilename).Sheets(合并).Range(a1) = fff
                End If
               
                tr = Workbooks(nfilename).Sheets(合并).[b65536].End(xlUp).Row + 1 '合并filename
                '数据缺失
                If er = 1 Then
                       Workbooks(nfilename).Sheets(合并).Range(a & tr) = fff
                       Workbooks(nfilename).Sheets(合并).Range(b & tr) = 数据缺失
                Else
                      ActiveSheet.UsedRange.Copy Workbooks(nfilename).Sheets(合并).Range(b & tr)
                      Workbooks(nfilename).Sheets(合并).Range(a & tr & a & tr + er - 1) = fff
                        Workbooks(nfilename).Sheets(合并).Rows(tr).Delete
                     
                End If
                ActiveWorkbook.Close False
                Workbooks(nfilename).Close True
       Next
    Next
  
Application.DisplayAlerts = True

End Sub

那谁谁

补充一下情况

那谁谁

KCFONG 发表于 2012-8-31 20:27
太可怜了
从前的日子多悠闲

KCFONG大神，帮再看看http://club.excelhome.net/thread-911708-4-1.html的报错问题嘛

LMY123

常规法，多夹同名工作薄合并成一薄一表

jjmysjg

再留记号，在线