将多个Excel文件批量导入某个Excel文件中

这是我老婆提出的一个需求：(1)选中Excel表格中的某些行或列，运行某个Macro，自动根据选中的cells创建新的worksheets，worksheets的名字就是选中的cells的名字。(2)创建新的worksheet的同时，要把某指定目录下与新的worksheet同名的Excel文件的内容copy到新的worksheet中去。

下面是搜索了半天之后搞出来的Macro，没有异常处理，而且使用了copy/paste，文件太多时效率肯定不高。其实完全可以参照

Copy a sheet from each workbook into your workbook in a folder using VBA in Microsoft Excel 和 Optimize Slow VBA Code 中的方法来优化。

Sub LoadSheets()
    Application.ScreenUpdating = False  ' stop screen flickering
    
    ' Create new sheets according to selected cells and copy the
    ' contebts of other files into the new sheets
    Dim YesNo As Variant, myFolder As String, MyLF As String
        
    MyLF = Chr(10) & Chr(13)    ' a line feed command
    myFolder = "D:Documents and SettingsbonnyMy Documentstools"   'change this to the location of saved XML files
    'Windows 7下C盘默认不可写，请修改DefFolder的值
    
    YesNo = MsgBox("This Macro is going to create new worksheets according to your selected cells." & myclf & _
        "Do you want to continue?", _
        vbYesNo, "Caution")
    Select Case YesNo
    Case vbYes
        myFolder = InputBox("Please enter the folder where all your Excel files locates", Default:=myFolder)
        'Create new worksheets
        For Each cell In Selection.Cells
            Call CreateNewWorksheet(cell.Value, myFolder)
        Next
    Case vbNo
        Exit Sub
    End Select
    
    Application.ScreenUpdating = True
End Sub

Function CreateNewWorksheet(SheetName As String, FolderName As String) As String

    Dim oSheet As Worksheet, vRet As Variant
    Dim fName As String
    
    'creating a new excel worksheet
    Set oSheet = Worksheets.Add
    With oSheet
        .Name = SheetName
        .Move after:=Sheets(Sheets.Count) '在当前所有worksheet后创建新的工作表
        .Activate
    End With
    
    'open Excel files and copy the contents to this sheet
    Dim newWB As Workbook, curWB As Workbook
    Dim startRange As Range
    
    Set curWB = ThisWorkbook ' For WorkBook and Range objects, set is necessary during assignment
    fName = FolderName + "" + SheetName + ".xls"
    Set newWB = Workbooks.Open(fName)
    newWB.Activate
    newWB.Sheets(1).Activate ' 假定只有第一个worksheet需要copy
    Set startRange = newWB.Sheets(1).UsedRange ' Only used range will be copied
    newWB.Sheets(1).UsedRange.Copy
    
    'select the destination cell
    curWB.Activate
    Sheets(SheetName).Activate
    Range(startRange.Address).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False  'Clear Clipboard
    newWB.Close
    
    Exit Function

End Function