一、不打开文件取值
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
评论