将来自不同工作簿的数据合并到主工作簿的特定工作表中

我想将3个名为Sub WB1,Sub WB2和Sub WB3的不同工作簿中名为“Task tracking”的工作表内容合并到单个Main Workbooks任务跟踪工作表中。 请帮忙。

总共有4个练习册,每个练习册有12个工作表。

  • 主要工作手册
  • 子WB1
  • 小组WB2
  • 子WB3

我想要使​​用主工作簿中的“合并”button将来自“子任务跟踪”(工作表名称)从子WB1,子WB2和子WB3中的数据合并到主工作簿中。

我用下面的代码,我从一些参考,但我得到运行时错误:1004请帮助。

Sub MergeSpecificWorkbooks() Dim MyPath As String Dim SourceRcount As Long, FNum As Long Dim mybook As Workbook, BaseWks As Worksheet Dim sourceRange As Range, destrange As Range Dim rnum As Long, CalcMode As Long Dim SaveDriveDir As String Dim FName As Variant 'Change ScreenUpdating, Calculation and EnableEvents With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With 'SaveDriveDir = CurDir 'ChDirNet "D:\DD_Task1\" path = "D:\DD_Task1\" 'FName = Application.GetOpenFilename("Sub WB1.xls, Sub WB2.xls, Sub WB3.xls", MultiSelect:=True) FName = Application.GetOpenFilename(filefilter:="Sub WB1.xlsm, Sub WB2.xlsm, Sub WB3.xlsm", _ MultiSelect:=True) If IsArray(FName) Then 'Add a new workbook with one sheet 'Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1) Set BaseWks = Worksheets.Add BaseWks.Name = "Master" rnum = 2 'Loop through all files in the array(myFiles) For FNum = LBound(FName) To UBound(FName) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(FName(FNum)) On Error GoTo 0 If Not mybook Is Nothing Then On Error Resume Next With mybook.Worksheets("H-POD") .Unprotect LC = .Cells(.Rows.Count, "C").End(xlUp).Row Set sourceRange = .Range("B10:M" & LC) End With If Err.Number > 0 Then Err.Clear Set sourceRange = Nothing Else 'if SourceRange use all columns then skip this file If sourceRange.Columns.Count >= BaseWks.Columns.Count Then Set sourceRange = Nothing End If End If On Error GoTo 0 If Not sourceRange Is Nothing Then SourceRcount = sourceRange.Rows.Count If rnum + SourceRcount >= BaseWks.Rows.Count Then MsgBox "Sorry there are not enough rows in the sheet" BaseWks.Columns.AutoFit mybook.Close savechanges:=False GoTo ExitTheSub Else 'Copy the file name in column A With sourceRange BaseWks.Cells(rnum, "A"). _ Resize(.Rows.Count).Value = FName(FNum) End With 'Set the destrange Set destrange = BaseWks.Range("B" & rnum) 'we copy the values from the sourceRange to the destrange With sourceRange Set destrange = destrange. _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = sourceRange.Value rnum = rnum + SourceRcount End If End If mybook.Close savechanges:=False End If Next FNum BaseWks.Columns.AutoFit End If ExitTheSub: 'Restore ScreenUpdating, Calculation and EnableEvents With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With ' ChDirNet SaveDriveDir End Sub 

GetOpenFilename()方法不接受"Sub WB1.xlsm, Sub WB2.xlsm, Sub WB3.xlsm"这样的FileFilter语法"Sub WB1.xlsm, Sub WB2.xlsm, Sub WB3.xlsm"

如果您希望用户select具有给定名称的文件,那么您必须使用UserForm

比如你可以这样做:

  • 更改:

     FName = Application.GetOpenFilename("Sub WB1.xls, Sub WB2.xls, Sub WB3.xls", MultiSelect:=True) 

    至:

     FName = GetFName() 
  • 添加下面的Function (可能在你的Sub的一个模块中)

     Function GetFName() As Variant Dim iList As Long Dim selectedFiles As String With ListFiles_UF With .ListBox1 .MultiSelect = fmMultiSelectMulti .List = Array("Sub WB1.xlsm", "Sub WB2.xlsm", "Sub WB3.xlsm") End With .Show With .ListBox1 If .ListIndex > 0 Then For iList = 0 To .ListCount - 1 If .Selected(iList) Then selectedFiles = selectedFiles & .List(iList) & "|" Next GetFName = Split(Left(selectedFiles, Len(selectedFiles) - 1), "|") End If End With End With End Function 
  • 添加一个UserForm到你的VBA项目,并在“ListFiles_UF”之后命名(你可以select任何其他有效的名字,但在整个代码中与其一致)

  • 在“ListFiles_UF”用户窗体中放置一个ListBox控件(默认情况下命名为“ListBox1”)和一个CommandButton控件(默认情况下命名为“CommandButton1”)

  • 把这段代码放到“ListFiles_UF”代码窗格中

     Private Sub CommandButton1_Click() Me.Hide End Sub