选中Excel单元格自动导入多个Excel worksheets

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

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

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

表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）：

                                         
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