注册 登录  
 加关注
   显示下一条  |  关闭
温馨提示!由于新浪微博认证机制调整,您的新浪微博帐号绑定已过期,请重新绑定!立即重新绑定新浪微博》  |  关闭

凉茶

 
 
 

日志

 
 

EXCEL跨表取值汇总  

2010-08-21 10:45:53|  分类: Excel自动化 |  标签: |举报 |字号 订阅

  下载LOFTER 我的照片书  |

一、不打开文件取值

Sub zldccmx()
    Application.EnableEvents = False

    Application.ScreenUpdating = False
    Set xap = GetObject("N:\Fab\Marking\Cutting\Data.xls")  '我要得到的文件的的路径是:N:\Fab\Marking\Cutting\Data.xls        
    arr = xap.Sheets("Sheet2").[B2:Q1000] '选择的区域是: Sheet2 , B2: Q1000 
    xap.Close False

    ThisWorkbook.Sheets("sheet1").[C2:R1000] = arr
    '我当前的文件路径是:N:\Fab\Marking\Report\Aug Report\Monthly Report.xls

    '需要覆盖的区域是: Sheet1 , C2: R1000
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub


打开有密码的文档

Sub zldccmx()
    Application.EnableEvents = False

    Application.ScreenUpdating = False
    Dim Xap As New
Excel.Application
    Xap.Workbooks.Open "N:\Fab\Marking\Cutting\Data.xls", , True
, , "2233"  '以只读方式打开,打开密码是“2233”
    '我要得到的文件的的路径是:N:\Fab\Marking\Cutting\Data.xls 
    arr = Xap.Sheets("Sheet1").[B2:Q1000]     '选择的区域是: Sheet2 , B2: Q1000
    Xap.Quit
    ThisWorkbook.Sheets("sheet1").[C2:R1000] = arr
    '我当前的文件路径是:N:\Fab\Marking\Report\Aug Report\Monthly Report.xls

    '需要覆盖的区域是: Sheet1 , C2: R1000
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 


二、

Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
 Sub kk()
'On Error Resume Next
Application.ScreenUpdating = False
    Dim myFs As FileSearch
    Dim myPath As String
    Dim i As Long, n As Long
     Dim ii As Integer
       Set myFs = Application.FileSearch
    myPath = ThisWorkbook.Path & "\"
    With myFs
        .NewSearch
        .LookIn = myPath
        .FileType = msoFileTypeAllFiles
        .Filename = "*.xls"
        .SearchSubFolders = True
        If .Execute(SortBy:=msoSortByFileName) > 0 Then
            n = .FoundFiles.Count
            ReDim myFile(1 To n) As String
            For i = 1 To n
                myFile(i) = .FoundFiles(i)
                If Dir(myFile(i)) = ThisWorkbook.Name Then GoTo 30
                Set AK = Workbooks.Open(myFile(i))          '打开符合要求的文件
          For ii = 1 To AK.Sheets.Count
         aRow = AK.Sheets(ii).Range("a65536").End(xlUp).Row
         tRow = ThisWorkbook.Sheets(1).Range("a65536").End(xlUp).Row + 1
         AK.Sheets(ii).Range("a3:k" & aRow).Copy ThisWorkbook.Sheets(1).Range("a" & tRow)
         Next
        ActiveWorkbook.Close False
30            Next
        End If
    End With
    Set myFs = Nothing   

    Application.ScreenUpdating = True
End Sub


 aa() 
   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

  评论这张
 
阅读(1724)| 评论(0)
推荐 转载

历史上的今天

评论

<#--最新日志,群博日志--> <#--推荐日志--> <#--引用记录--> <#--博主推荐--> <#--随机阅读--> <#--首页推荐--> <#--历史上的今天--> <#--被推荐日志--> <#--上一篇,下一篇--> <#-- 热度 --> <#-- 网易新闻广告 --> <#--右边模块结构--> <#--评论模块结构--> <#--引用模块结构--> <#--博主发起的投票-->
 
 
 
 
 
 
 
 
 
 
 
 
 
 

页脚

网易公司版权所有 ©1997-2017