VBA 从一个未打开的Excel文件中读取数据到，已打开的文件中.

Private   Sub CommandButton1_Click() Sub CommandButton1_Click()
    Call Macro1
End Sub

Private   Sub CommandButton2_Click() Sub CommandButton2_Click()
''根据项目名称 获取部门名
'A8    显示在B8中     c3--c40
Dim xDis As Integer
Dim xNo As Integer
Dim strProject  '项目名称
Dim strDep '制造部门

 Dim myPath$, myFile$, AK As Workbook, aRow%, tRow%, i As Integer
   Application.ScreenUpdating = False        '冻结屏幕，以防屏幕抖动
   myPath = ThisWorkbook.Path & "/"          '把文件路径定义给变量
   
   myFile = Dir(myPath & "data.xls")            '依次找寻指定路径中的*.xls文件

xDis = 40
   strname = ActiveWorkbook.Name
    Set AK = Workbooks.Open(myPath & myFile)     '打开符合要求的文件
For xNo = 3 To xDis

    strProject = Workbooks(strname).Worksheets("System").Range("A8").Value
    strDep = Workbooks(strname).Worksheets("System").Range("B8").Value

  
     If (strProject = AK.Worksheets("二部").Range("C" & CStr(xNo)).Value) Then
        Workbooks(strname).Worksheets("System").Range("B8").Value = "二部"
        Exit For
    End If
    
     If (strProject = Workbooks("data.xls").Worksheets("三部").Range("C" & CStr(xNo)).Value) Then
        Workbooks(strname).Worksheets("System").Range("B8").Value = "三部"
        Exit For
    End If
    
     If (strProject = Workbooks("data.xls").Worksheets("四部").Range("C" & CStr(xNo)).Value) Then
        Workbooks(strname).Worksheets("System").Range("B8").Value = "四部"
        
        Exit For
    End If

     If (strProject = Workbooks("data.xls").Worksheets("五部").Range("C" & CStr(xNo)).Value) Then
        Workbooks(strname).Worksheets("System").Range("B8").Value = "五部"
        Exit For
    End If
    
Next xNo
 Workbooks(myFile).Close False
    Application.ScreenUpdating = True                 '冻结屏幕,此类语句一般成对使用

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
End Sub

Sub 按钮1_单击() Sub 按钮1_单击()
   Dim myPath$, myFile$, AK As Workbook, aRow%, tRow%, i As Integer
   Application.ScreenUpdating = False        '冻结屏幕，以防屏幕抖动
   myPath = ThisWorkbook.Path & "/分表/"          '把文件路径定义给变量
   myFile = Dir(myPath & "*.xls")            '依次找寻指定路径中的*.xls文件
   Do While myFile <> ""                     '当指定路径中有文件时进行循环
      If myFile <> ThisWorkbook.Name Then
         Set AK = Workbooks.Open(myPath & myFile)          '打开符合要求的文件
          For i = 1 To AK.Sheets.Count
         aRow = AK.Sheets(i).Range("a65536").End(xlUp).Row
         tRow = ThisWorkbook.Sheets(1).Range("a65536").End(xlUp).Row + 1
            'AK.Sheets(i).Select
         AK.Sheets(i).Range("a3:k" & aRow).Copy ThisWorkbook.Sheets(1).Range("a" & tRow)
         Next
         Workbooks(myFile).Close False               '关闭源工作簿,并不作修改
      End If
      myFile = Dir                                   '找寻下一个*.xls文件
   Loop
   Application.ScreenUpdating = True                 '冻结屏幕,此类语句一般成对使用
   MsgBox "汇总完成，请查看！", 64, "提示"
End Sub

http://www.cnblogs.com/wj-wangjun/archive/2007/08/29/875034.html