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

KCFONG

Please see if fit your request

sunnystar

KCFONG 发表于 2012-8-29 22:49
Please see if fit your request

很赞啊！还实现了显示缺失值路径！
就是合并之后打开时还有原来的提示: “格式与文件扩展名指定的格式不一致”。是什么原因呢？因为合并好的数据可能会交给其他同事。
万分感谢！感谢您的及时帮助！我可以缓解出时间做更多有价值的事情了。

KCFONG

Pleae test


Sub 合并()
Application.DisplayAlerts = False
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(ThisWorkbook.Path)
For Each ff In f.Files
  If ff.Name <> ThisWorkbook.Name Then
    Kill ff
  End If
Next ff
    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

sunnystar

KCFONG 发表于 2012-8-29 23:11
Pleae test

您写出的代码运行后，出现“运行时错误9 下标越界”   品牌1~5文件没有生成，品牌6、7生成好了
tr = Workbooks(nfilename).Sheets("合并").[b65536].End(xlUp).Row + 1 '合并filename
调试之后显示中后部位的这句有问题


代码不懂，您有时间再做更改吧。
非常非常感谢您的帮助，晚安！

KCFONG

上传你的档案

sunnystar

KCFONG 发表于 2012-8-29 23:47
上传你的档案

从不同文件夹中汇总到一个EXCEL v5.rar (273.8 KB, 下载次数: 9)

2012-8-29 23:56 上传

点击文件名下载附件

附件
我将您最新回复的代码粘贴进去运行，结果出现下标越界。
合并的结果也在此附件中。

我明白了出现问题上传附件。再次感谢！
时间晚了，您有时间再帮我抽空解答吧！晚安！太感谢您了！！！

KCFONG

Please test

sunnystar

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

感谢您这么早的回复。
今早到公司TEST了一下，完美实现！！！
太太太感谢您了！

KCFONG

Don't tell your boss,
and seems work as past
种下菜 养下动物

sunnystar

KCFONG 发表于 2012-8-30 09:22
Don't tell your boss,
and seems work as past
种下菜 养下动物

是啊。；）
还可以多学点习。之前没时间提升水准。
这两天又忙的都没时间回复。下班又赶上断网。