|
- Sub tst()
- Dim strPath As String, strFile As String
- Dim objWorkbook As Workbook
- Dim arr(), lCount As Long
- On Error GoTo ErrorHandler
-
- With Application
- .ScreenUpdating = False
- .DisplayAlerts = False
- .EnableEvents = False
- .Calculation = xlCalculationManual
- End With
- strPath = ThisWorkbook.Path & Application.PathSeparator
- strFile = Dir(strPath & "*.xls")
- Do While Len(strFile)
- If strFile <> ThisWorkbook.Name Then
- '找到文件后执行的操作
- lCount = lCount + 1
- ReDim Preserve arr(1 To 2, 1 To lCount)
- Set objWorkbook = GetObject(strPath & strFile)
- Windows(objWorkbook.Name).Visible = True
- With objWorkbook
- arr(1, lCount) = Replace(strFile, ".xls", "")
- arr(2, lCount) = .Worksheets("sheet1").Range("e22")
- .Close False
- End With
- End If
- strFile = Dir
- Loop
-
- If lCount Then
- ActiveSheet.UsedRange.Clear
- Range("a1").Resize(, 2) = Array("文件名", "结果")
- Range("a2").Resize(lCount, 2).Value = WorksheetFunction.Transpose(arr)
- With Range("a1").CurrentRegion
- .Borders.LineStyle = xlContinuous
- .EntireColumn.AutoFit
- End With
- End If
-
- With Application
- .ScreenUpdating = True
- .DisplayAlerts = True
- .EnableEvents = True
- .Calculation = xlCalculationAutomatic
- End With
- MsgBox "提取完成"
- Exit Sub
-
- ErrorHandler:
- MsgBox Err.Number & vbCrLf & Err.Description
- With Application
- .ScreenUpdating = True
- .DisplayAlerts = True
- .EnableEvents = True
- .Calculation = xlCalculationAutomatic
- End With
- End Sub
复制代码 |
|