选中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）：

<span style="font-family: 'Times New Roman'; font-size: 16px;"></span><pre style="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 </pre>

如要自动导入每个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