Two days ago, my wife asked me to write an Excel VBA script to automatically import multi-Excel worksheets stored in different workbooks into an already opened Excel workbook.  Her requirements were:

  1. Select a range in a worksheet, which stores the names of worksheets to be imported. After executing the macro, worksheets will be created if it doesn't exist, or it will be updated according to the specified  Excel worksheet in another Excel workbook. Table 1 is the range selected in the worksheet, in which the first column is the serial number of worksheet, the second column denotes department name and the worksheet name should be like "01 Department A".
  2. The imported/created worksheets should be sorted by the serial number of Table 1.
  3. The macro should be smart enough to match the Excel files to be imported. The name is like "01 XXXX_Department  A_20110707.xls".
  4. After importing, specified cells in every other worksheets should be automatically copied to cells on the same row next to department.

Table 1  Selected Range of a worksheet

1 Department  A
2 Department  B
3 Department  C
4 Department  D
5 Department  E
6 Department  F
7 Department  G
8 Department  H
9 Department  I
10 Department  J

Actually I am not familiar with VBA, although I studied Visual Basic 6.0 for several months, I rarely touched it after passing the Jiangsu Province Computer Rank Test Level 2 in 2003. Besides, almost all my work was done in Linux/UNIX last 3 years.  As a result, I have to Google every VBA syntax and tips all day long.

Finally, I finishes the VBA macros and meet my wife's requirement in a inelegant way. Following is the verbose source code.

Following the macro to implement first 3 requirements.
[sourcecode language="vb"]
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


' Sort worksheets
Call SortWorksheets

Case vbNo
Application.ScreenUpdating = True
Exit Sub
End Select

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
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)
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
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
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
' paste to target worksheet
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

If Coll_Docs.Count = 1 Then
FindFileName = Search_path & "\" & Coll_Docs(1)
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 0 Then
Entry = i
GoTo Determ_Entry
End If
Next i

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

'Application.ScreenUpdating = True
End Function

And here comes the macro to implement the 4th requirement.
[sourcecode language="vb"]
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)

Risk5.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Application.CutCopyMode = False 'Clear Clipboard

idx = idx + 1

Application.ScreenUpdating = True
End Sub