谨以此网站,向Godick致敬

Dim myDate as Date
myDate=#4/5/2011#
Debug.Print Format(DateSerial(2011, VBA.Month(myDate), 1), "mmm")

'format(____, "mmm"): Jan, Feb,etc
'format(____, "mmmm"): January, February,etc

'You must set a reference to the
'Microsoft ActiveX Data Objects 2.5 library in the VBA editor
'http://en.allexperts.com/q/Excel-1059/Copy-closed-workbook.htm
Option Explicit

Sub GetData_ClosedWorkBook()
   Dim sh As Worksheet
   Dim rDest As Range
   Dim SaveDriveDir As String
   Dim sPath As String
   Dim FName As Variant
   Dim N As Long
   Dim lNum As Long

   SaveDriveDir = CurDir
   sPath = Application.DefaultFilePath    'or use "C:\Data"
  ChDrive sPath
   ChDir sPath

   FName = Application.GetOpenFilename(filefilter:="Excel Files,*.xls", _
                                       MultiSelect:=True)
   If IsArray(FName) Then

       ' Sort the Array
      FName = Array_Sort(FName)

       Application.ScreenUpdating = False
       'Add worksheet to the Activeworkbook and use the Date/Time as name
      'You can change this to suit
      Set sh = ActiveWorkbook.Worksheets.Add
       sh.Name = Format(Now, "dd-mm-yy h-mm-ss")

       'Loop through all files you select in the GetOpenFilename dialog
      For N = LBound(FName) To UBound(FName)

           'Find the last row with data
          lNum = LastRow(sh)

           'create the destination cell address
          Set rDest = sh.Cells(lNum + 1, 1)

           ' For testing Copy the workbook name in Column E
          sh.Cells(lNum + 1, 5).Value = FName(N)

           'Get the cell values and copy it in the rDest
          'Change the Sheet name and range as you like
          GetData FName(N), "Income", "A1:K100", rDest, False, False

       Next
   End If

   ChDrive SaveDriveDir
   ChDir SaveDriveDir
   Application.ScreenUpdating = True
End Sub

Now add another module and copy & paste these Functions

Option Explicit

Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
                  sourceRange As String, TargetRange As Range, _
                  Header As Boolean, UseHeaderRow As Boolean)
   Dim rsData As ADODB.Recordset
   Dim szConnect As String
   Dim szSQL  As String
   Dim lCount As Long

   If Header = False Then
       ' Create the connection string.
      szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                   "Data Source=" & SourceFile & ";" & _
                   "Extended Properties=""Excel 8.0;HDR=No"";"
   Else
       ' Create the connection string.
      szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                   "Data Source=" & SourceFile & ";" & _
                   "Extended Properties=""Excel 8.0;HDR=Yes"";"
   End If

   szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & sourceRange$ & "];"
   On Error GoTo SomethingWrong
   Set rsData = New ADODB.Recordset
   rsData.Open szSQL, szConnect, adOpenForwardOnly, _
               adLockReadOnly, adCmdText

   ' Check to make sure we received data and copy the data
  If Not rsData.EOF Then
       If Header = False Then
           TargetRange.Cells(1, 1).CopyFromRecordset rsData
       Else
           'Add the header cell in each column if the last argument is True
          If UseHeaderRow Then
               For lCount = 0 To rsData.Fields.Count - 1
                   TargetRange.Cells(1, 1 + lCount).Value = _
                   rsData.Fields(lCount).Name
               Next lCount
               TargetRange.Cells(2, 1).CopyFromRecordset rsData
           Else
               TargetRange.Cells(1, 1).CopyFromRecordset rsData
           End If
       End If
   Else
       MsgBox "No records returned from : " & SourceFile, vbCritical
   End If

   ' Clean up our Recordset object.
  rsData.Close
   Set rsData = Nothing
   Exit Sub
SomethingWrong:
   MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
          vbExclamation, "Error"
   On Error GoTo 0
End Sub


Function LastRow(sh As Worksheet)
   On Error Resume Next
   LastRow = sh.Cells.Find(What:="*", _
                           After:=sh.Range("A1"), _
                           Lookat:=xlPart, _
                           LookIn:=xlFormulas, _
                           SearchOrder:=xlByRows, _
                           SearchDirection:=xlPrevious, _
                           MatchCase:=False).Row
   On Error GoTo 0
End Function


Function Array_Sort(ArrayList As Variant) As Variant
   Dim aCnt As Integer, bCnt As Integer
   Dim tempStr As String
   For aCnt = LBound(ArrayList) To UBound(ArrayList) - 1
       For bCnt = aCnt + 1 To UBound(ArrayList)
           If ArrayList(aCnt) > ArrayList(bCnt) Then
               tempStr = ArrayList(bCnt)
               ArrayList(bCnt) = ArrayList(aCnt)
               ArrayList(aCnt) = tempStr
           End If
       Next bCnt
   Next aCnt
   Array_Sort = ArrayList
End Function