将多个工作簿从不同的文件夹合并成一个 [英] Merge Multiple Workbooks From Different Folders Into One

问题描述

我使用下面的代码来允许用户将来自不同文件夹的多个工作簿合并成一个摘要工作表。

  Sub Merge（）
 
 Dim DestWB As Workbook，WB As Workbook， WS As Worksheet，SourceSheet As String 
设置DestWB = ActiveWorkbook 
 SourceSheet =Input
 startrow = 7 
 FileNames = Application.GetOpenFilename（_ 
 filefilter：= Excel文件（* .xls *），*。xls *，_ 
标题：=选择要合并的工作簿，MultiSelect：= True）
如果IsArray（FileNames）= False Then 
如果FileNames = False然后
退出Sub 
结束If 
结束If 
对于n = LBound（FileNames）到UBound（FileNames）
设置WB =工作簿.Open（文件名：= FileNames（n），ReadOnly：= True）
对于每个WS在WB.Worksheets 
如果WS.Name = SourceSheet n 
带有WS 
如果.UsedRange.Cells.Count> 1然后
 dr = DestWB.Worksheets（Input）。Range（C& DestWB.Worksheets（Input）。Rows.Count）.End（xlUp）.Row + 1 
 Lastrow = .Range（C& Rows.Count）.End（xlUp）.Row 
如果Lastrow> = startrow Then 
 .Range（A& startrow&：AE & Lastrow）.Copy 
 DestWB.Worksheets（Input）。Cells（dr，A）。PasteSpecial xlValues 
 End If 
 End If 
 End With 
退出
结束如果
下一个WS 
 WB.Close savechanges：= False 
下一个n 
 End Sub 
  

代码可以正常工作，但是我想调整一下，这样，用户不必手动选择要合并的文件，宏读取文件名和文件路径的列表，并自动复制和粘贴相关数据进入摘要表。

我已经设置了我的Summary工作簿，所以有一个名为Lists的工作表，其中列出了B3：B10中的文件名并在C3：C10中关联文件路径。我搜索过Stackoverflow并进行了Google搜索，虽然我发现了一些关于这个主题的帖子，但是他们并没有向我展示如何从文件名和路径列表中读取，而是对特定的目录，不符合我的需要。

我只是想知道有人可能会看这个请求，并提供一些指导，我可以如何实现这一点。 / p>

非常感谢和善意

解决方案

请使用加载项RDBMerge。

RDBMerge是将多个Excel工作簿中的数据合并为一个用户友好的方式，
csv和xml文件到摘要工作簿中

http://www.rondebruin.nl/merge.htm

I wonder whether someone may be able to help me please.

I'm using the code below to allow a user to merge multiple workbooks from different folders into one 'Summary' worksheet.

Sub Merge()

      Dim DestWB As Workbook, WB As Workbook, WS As Worksheet, SourceSheet As String
      Set DestWB = ActiveWorkbook
      SourceSheet = "Input"
      startrow = 7
      FileNames = Application.GetOpenFilename( _
      filefilter:="Excel Files (*.xls*),*.xls*", _
      Title:="Select the workbooks to merge.", MultiSelect:=True)
      If IsArray(FileNames) = False Then
          If FileNames = False Then
              Exit Sub
          End If
      End If
      For n = LBound(FileNames) To UBound(FileNames)
          Set WB = Workbooks.Open(Filename:=FileNames(n), ReadOnly:=True)
          For Each WS In WB.Worksheets
              If WS.Name = SourceSheet Then
                  With WS
                      If .UsedRange.Cells.Count > 1 Then
                          dr = DestWB.Worksheets("Input").Range("C" & DestWB.Worksheets("Input").Rows.Count).End(xlUp).Row + 1
                          Lastrow = .Range("C" & Rows.Count).End(xlUp).Row
                          If Lastrow >= startrow Then
                              .Range("A" & startrow & ":AE" & Lastrow).Copy
                              DestWB.Worksheets("Input").Cells(dr, "A").PasteSpecial xlValues
                          End If
                      End If
                  End With
                  Exit For
              End If
          Next WS
          WB.Close savechanges:=False
      Next n
  End Sub

The code works, but I'd like to tweak this a little, so that instead of the user having to manually select the files to merge, the macro reads a list of the file names and file paths and automatically copies and pastes the relevant data into the "Summary" sheet.

I've set my Summary workbook up so there is a sheet called "Lists" with the file names listed in B3:B10 and in C3:C10 the associated file paths. I've searched "Stackoverflow" and carried out Google searches, and although I've found a number of posts on this topic, they don't show me how to read from a list of filenames and paths, but rather hard coding a specific directory which doesn't suit my needs.

I just wondered whether someone could possibly look at this please and offer some guidance on how I may be able to acheive this.

Many thanks and kind regards

解决方案

Kindly use the addin RDBMerge.

RDBMerge is a user friendly way to Merge Data from Multiple Excel Workbooks, csv and xml files into a Summary Workbook

http://www.rondebruin.nl/merge.htm

这篇关于将多个工作簿从不同的文件夹合并成一个的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！