使用範圍將Excel工作簿組合到一個主文件副本中

Question

您好，我需要通過從目錄中選擇工作簿來組合工作簿的列表。複製活動工作簿中的一系列數據並將其粘貼到新的主工作簿中。然後從另一個工作簿複製另一範圍的數據以粘貼到新粘貼的單元格附近。然後我需要重複一個目錄中的多個文件的過程。以下是我迄今爲止發現的代碼：

Option Explicit 

'Combine Workbooks 
'This sample goes through all the Excel files in a specified directory and combines theminto 
'a single workbook. It renames the sheets based on the name of the original workbook: 
Sub CombineSourceWorkbooks() 
Dim CurFile As String, DirLoc As String 
Dim DestWb As Workbook 
Dim wbkOpen As Workbook 
Dim WS As Object 'allows for different sheet types 

DirLoc = "C:\MyFiles\" 
CurFile = Dir(DirLoc & "*.xls") 

Application.ScreenUpdating = False 
Application.EnableEvents = False 

Set DestWb = Workbooks.Add(xlWorksheet) 

Do While CurFile <> vbNullString 
    Dim OrigWb As Workbook 
    Set OrigWb = Workbooks.Open(Filename:=DirLoc & CurFile, ReadOnly:=True) 

    ' Limit to valid sheet names and remove .xls* 
    CurFile = Left(Left(CurFile, Len(CurFile) - 5), 29) 

     OrigWb.Sheets.Copy After:=DestWb.Sheets(DestWb.Sheets.Count) 
    'Name the File 

     DestWb.Sheets(DestWb.Sheets.Count).Name = CurFile 
    'Delete unwanted columns 
     DestWb.Sheets(DestWb.Sheets.Count).Range("A:C,H:P").Delete (xlToLeft) 
       OrigWb.Close SaveChanges:=False 
     CurFile = Dir 
     ' Set wbkOpen = Workbooks.Open(DirLoc & CurFile, False, True) 




Loop 

Application.DisplayAlerts = False 
    DestWb.Sheets(1).Delete 
Application.DisplayAlerts = True 

Application.ScreenUpdating = True 
Application.EnableEvents = True 

Set DestWb = Nothing 

End Sub 

Answer 1

您可以使用此方法。

Sub combine() 

    Dim app As New Excel.Application 
    app.Visible = False 

    Dim wbM As Workbook 
    Set wbM = ActiveWorkbook 

    Dim fd As FileDialog 
    Set fd = Application.FileDialog(msoFileDialogFilePicker) 
    fd.AllowMultiSelect = True 
    Files = fd.Show 

    For i = 1 To fd.SelectedItems.Count 
     app.Workbooks.Open fd.SelectedItems(i) 
    Next i 

    Dim wb As Workbook 
    For Each wb In app.Workbooks 
     If wb.Name <> "main.xlsb" Then 
      Dim wsN As Worksheet 
      Set wsN = wbM.Sheets.Add(after:=wbM.Sheets(wbM.Sheets.Count)) 
      wsN.Name = wb.Name 

      wbM.Sheets(wb.Name).Range("A1:K10").Value = wb.Sheets(1).Range("A1:K10").Value 

      wb.Close SaveChanges:=False 
     End If 
    Next 

    app.Quit 
    Set app = Nothing 

End Sub 

另外，請嘗試下面的AddIn。

http://www.rondebruin.nl/win/addins/rdbmerge.htm