前日完成将多个Excel文件批量导入某个Excel文件中老婆规定的任务后，老婆又提出了新的要求：

  1. 可以update每个worksheet
  2. 对导入的worksheets进行排序
  3. 自动匹配代导入文件的文件名
  4. 将导入的worksheets中的特定多个单元格（cells）的内容自动填充到某一表格的特定区域

本文中用到的Excel文件及VBA宏可以在此处下载。

表1  选中的单元格
1 工作表 1
2 工作表 2
3 工作表 3
4 工作表 4
5 工作表 5
6 工作表 6
7 工作表 7
8 工作表 8
9 工作表 9
10 工作表 10

对应的各个worksheet的名字(Name)是：01 工作表 1， 02 工作表 2，03 工作表 3，……，10 工作表 10.


待导入的Excel文件的名字为“02 某某银行XX项目_工作表 1_20110701.xls”。

Update 2011-07-13 21:50

应老婆的要求，更新了程序，遇到并解决的问题有：

  1. Office 2003和2007不兼容——有些method在office2003中正常工作但在office2007中却不再支持，如判定某文件是否存在的函数，解决方法参见FindFileName函数。
  2. 如果某个表中的一些单元格被筛选，则会遇到“不能复制合并的单元格”(Can't copy merged cell)的问题，解决方法就是在copy前强制关闭autofilter:   newWB.Sheets(SheetToBeCopy).AutoFilterMode = False ' disable auto filter
  3. 关闭打开的Excel文件或者copy单元格时会有各种各样的对话框弹出来，解决办法就是加上下面语句：

Application.DisplayAlerts = True
newWB.Close SaveChanges:=False  ' close without change
Application.DisplayAlerts = True

Update 2011-07-14 15:37

傻瓜型用户的需求就是无穷无尽啊……我老婆发现在选择不连续的区域时，只有第一个区域会被处理，其他的没有变化。顶着挨骂的压力Google之后才知道，原来Slection.Areas可以包含所有不连续的选择，然后通过遍历，处理所有的选择……程序改动如下。

       ' Create new worksheets
        ' Discontinuous selection is supported by Selection.Areas
        For Each Rng In Selection.Areas
            Set SelRange = Rng.Cells
            Set ColNo = Rng.Columns(1)
            Set ColDepart = Rng.Columns(2)
            idx = 1
            For Each cell In ColDepart.Cells
                no_str = ColNo.Cells(idx).Value
                If Len(no_str) = 1 Then
                    no_str = "0" + no_str
                End If
                Call CreateNewWorksheet(no_str, cell.Value, myFolder, SheetToBeCopy) ' call is needed here
                idx = idx + 1
            Next
        Next

实现以上所有需求的代码如下（Update 2011-07-14 15:37）：

<span style="font-family: 'Times New Roman';font-size:16px; "></span><pre style="word-wrap: break-word; white-space: pre-wrap; ">                                         
Option Explicit
Dim curWS As Worksheet


Sub LoadWorksheets()
'
' LoadWorksheets Macro
' Macro recorded 7/13/2011 by Bo Yang
'
' Keyboard Shortcut: Ctrl+Shift+L
'
' *How to use this macro?*
' *Select columns "??(NO)" and "??(Deparment)" and then run this macro.*
'
    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
    Dim SelRange As Range, ColNo As Range, ColDepart As Range, cell As Range, Rng As Range
    Dim SheetName As String, SheetToBeCopy As String
    Dim ColCnt As Integer
    Dim no_str As String, idx As Integer
        
    myFolder = "D:"   '*****Change this value as you need*****
    SheetToBeCopy = "信息资产风险评估"  ' *****Change this value as you need*****
    
    MyLF = Chr(10) & Chr(13)    ' a line feed command
    Set curWS = ThisWorkbook.ActiveSheet ' Save current worksheet
    
    ' check that if user select valid columns
    ColCnt = Selection.Columns.Count
    
    If ColCnt <> 2 Then
        MsgBox ("Please select 2 columns!!!" & MyLF & _
            "The first column must be digital numbers," & MyLF & _
            "And the Second column must be department names" _
        )
        Exit Sub
    End If
    
    YesNo = MsgBox("This Macro is going to create new worksheets according to your selected cells." & MyLF & _
        "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)
        SheetToBeCopy = InputBox("Please enter the worksheet you want to copy:", Default:=SheetToBeCopy)
        
        ' Create new worksheets
        ' Discontinuous selection is supported by Selection.Areas
        For Each Rng In Selection.Areas
            Set SelRange = Rng.Cells
            Set ColNo = Rng.Columns(1)
            Set ColDepart = Rng.Columns(2)
            idx = 1
            For Each cell In ColDepart.Cells
                no_str = ColNo.Cells(idx).Value
                If Len(no_str) = 1 Then
                    no_str = "0" + no_str
                End If
                Call CreateNewWorksheet(no_str, cell.Value, myFolder, SheetToBeCopy) ' call is needed here
                idx = idx + 1
            Next
        Next
        
        curWS.Activate
        
        ' Sort worksheets
        Call SortWorksheets
        
    Case vbNo
        Application.ScreenUpdating = True
        Exit Sub
    End Select
    
    curWS.Activate
    Application.ScreenUpdating = True
End Sub


Function CreateNewWorksheet(no As String, Depart As String, FolderName As String, SheetToBeCopy As String) As String
    Dim oSheet As Worksheet, vRet As Variant
    Dim SheetName As String, FileName As String
    Dim Entry As Integer, i As Integer


    ' Determine where to insert new worksheet
    Entry = 0
    For i = Sheets.Count To 1 Step -1
        If Val(Worksheets(i).Name) > 0 Then
            Entry = i
            GoTo Determ_Entry
        End If
    Next i
Determ_Entry:
    If Entry = 0 Then
        Entry = Sheets.Count
    End If
    
    'Example of one worksheet name:
    '   07 oa祙?DDISMS?ㄩ????_D???钻2???_D?'?轶???_20110705.xls
    SheetName = no + " " + Depart
    If Not SheetExists(SheetName) Then
        'worksheet XXX doesn't exist in current workbook
        'creating a new excel worksheet
        
        Set oSheet = Worksheets.Add
        With oSheet
            .Name = SheetName
            .Move After:=Sheets(Entry)
            .Activate
        End With
    End If
    
    FileName = FindFileName(no, Depart, FolderName)
    If FileName <> "" Then
        Call CopyWorksheet(SheetName, FileName, SheetToBeCopy)
    End If
    
    Exit Function


End Function


Function SheetExists(SheetName As String) As Boolean
' returns TRUE if the sheet exists in the active workbook
    SheetExists = False
    On Error GoTo NoSuchSheet
    If Len(Sheets(SheetName).Name) > 0 Then
        SheetExists = True
        Exit Function
    End If
NoSuchSheet:
End Function


Function CopyWorksheet(SheetName As String, FileName As String, SheetToBeCopy As String) As String
    'open Excel files and copy the contents to this sheet
    Dim newWB As Workbook, curWB As Workbook
    Dim startRange As Range
    
    If Dir(FileName) <> "" Then
        ' file exists
        ' Clear all cells of current worksheet
        Sheets(SheetName).UsedRange.Clear
        Application.DisplayAlerts = False ' disable alerts
        
        ' Open workbooks to be copied
        Set curWB = ThisWorkbook ' For WorkBook and Range objects, set is necessary during assignment
        Set newWB = Workbooks.Open(FileName)
        newWB.Sheets(SheetToBeCopy).AutoFilterMode = False ' disable auto filter
        Set startRange = newWB.Sheets(SheetToBeCopy).UsedRange ' Only used range will be copied
        newWB.Sheets(SheetToBeCopy).UsedRange.Copy
        ' paste to target worksheet
        curWB.Activate
        Sheets(SheetName).Range(startRange.Address).PasteSpecial
        Application.CutCopyMode = False  'Clear Clipboard
        newWB.Close SaveChanges:=False  ' close without change
        Application.DisplayAlerts = True
        
    End If


End Function


Function FindFileName(no As String, Depart As String, FolderName As String) As String
    Dim Coll_Docs As New Collection
    Dim Search_path, Search_Filter, Search_Fullname As String
    Dim DocName As String
    Dim i As Long


    Search_path = FolderName   ' where ?
    Search_Filter = no + "*" + Depart + "*" + ".xls" ' what ?
    Set Coll_Docs = Nothing


    DocName = Dir(Search_path & "" & Search_Filter)


    Do Until DocName = ""            ' build the collection
        Coll_Docs.Add Item:=DocName
        DocName = Dir
    Loop
    
    If Coll_Docs.Count = 1 Then
        FindFileName = Search_path & "" & Coll_Docs(1)
    Else
        FindFileName = ""
    End If


End Function


Function SortWorksheetsByName() As String
    ' sort worksheets in a workbook in ascending order
    Dim sCount As Integer, i As Integer, j As Integer
    
    Application.ScreenUpdating = False
    sCount = Worksheets.Count
    If sCount = 1 Then Exit Function
    For i = 1 To sCount - 1
        For j = i + 1 To sCount
            If Worksheets(j).Name < Worksheets(i).Name Then
                Worksheets(j).Move Before:=Worksheets(i)
            End If
        Next j
    Next i
    
End Function


Function SortWorksheets() As String
    ' sort worksheets in a workbook in ascending order
    Dim cnt As Integer, i As Integer, j As Integer
    Dim Entry As Integer
    Dim curWS As Worksheet
    
    Set curWS = ThisWorkbook.ActiveSheet
    'Application.ScreenUpdating = False
    
    cnt = Worksheets.Count
    
    ' Determine where to start sorting
    Entry = 0
    For i = 1 To cnt
        If Val(Worksheets(i).Name) > 0 Then
            Entry = i
            GoTo Determ_Entry
        End If
    Next i
Determ_Entry:
        
    For i = Entry To cnt - 1
            For j = i + 1 To cnt
                    If Val(Worksheets(i).Name) > Val(Worksheets(j).Name) Then
                            Worksheets(j).Move Before:=Worksheets(i)
                    End If
            Next j
    Next i
    
    curWS.Activate
    'Application.ScreenUpdating = True
End Function



如要自动导入每个worksheet的特定单元格（L2:L6）到表2中的D，E，F，G，H列，可以使用下面的UpdateCells宏。




Option Explicit

Sub UpdateCells()
'
' UpdateCells Macro
' Macro recorded 7/13/2011 by Bo Yang
'
' Keyboard Shortcut: Ctrl+Shift+C
'
' Risk:Cell
' 5: L2 , 4: L3 , 3: L4 , 2: L5 , 1: L6
Dim Risk5 As Range
Dim num As String, depart As Range, idx As Integer
Dim SheetName As String
Dim SelRange As Range
Dim curWS As Worksheet

Application.ScreenUpdating = False

Set curWS = ActiveSheet
Set SelRange = Selection

idx = 1
For Each depart In SelRange.Columns(2).Cells
    num = SelRange.Columns(1).Cells(idx).value
    If Len(num) = 1 Then
        num = "0" + num
    End If
    SheetName = num + " " + depart.value
    
    Set Risk5 = SelRange.Columns(3).Cells(idx)
    
    ThisWorkbook.Sheets(SheetName).Range("L2:L6").Copy
    Risk5.Select
    Risk5.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    Application.CutCopyMode = False 'Clear Clipboard
    
    idx = idx + 1
Next

Application.ScreenUpdating = True
End Sub