Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 3949|回复: 20

[已解决]求VBA,谢谢老师

[复制链接]
发表于 2013-7-20 19:46 | 显示全部楼层 |阅读模式
已知 文件夹中 存在文件名为  A0310000001 到 A0310000007 ,为了演示只做了7个,但实际应用中可能会是N个文件,现在需要从这几个文件的sheet1工作表E22单元格中取数,放入到 示例文件  里面B列对应的单元格中,求VBA  谢谢老师 示例.rar (24.57 KB, 下载次数: 12)
发表于 2013-7-20 20:02 | 显示全部楼层
  1. Sub tst()

  2.     Dim strPath As String, strFile As String
  3.     Dim objWorkbook As Workbook
  4.     Dim arr(), lCount As Long

  5.     On Error GoTo ErrorHandler
  6.    
  7.     With Application
  8.         .ScreenUpdating = False
  9.         .DisplayAlerts = False
  10.         .EnableEvents = False
  11.         .Calculation = xlCalculationManual
  12.     End With

  13.     strPath = ThisWorkbook.Path & Application.PathSeparator
  14.     strFile = Dir(strPath & "*.xls")

  15.     Do While Len(strFile)
  16.         If strFile <> ThisWorkbook.Name Then
  17.             '找到文件后执行的操作
  18.             lCount = lCount + 1
  19.             ReDim Preserve arr(1 To 2, 1 To lCount)
  20.             Set objWorkbook = GetObject(strPath & strFile)
  21.             Windows(objWorkbook.Name).Visible = True
  22.             With objWorkbook
  23.                 arr(1, lCount) = Replace(strFile, ".xls", "")
  24.                 arr(2, lCount) = .Worksheets("sheet1").Range("e22")
  25.                 .Close False
  26.             End With
  27.         End If
  28.         strFile = Dir
  29.     Loop
  30.    
  31.     If lCount Then
  32.         ActiveSheet.UsedRange.Clear
  33.         Range("a1").Resize(, 2) = Array("文件名", "结果")
  34.         Range("a2").Resize(lCount, 2).Value = WorksheetFunction.Transpose(arr)
  35.         With Range("a1").CurrentRegion
  36.             .Borders.LineStyle = xlContinuous
  37.             .EntireColumn.AutoFit
  38.         End With
  39.     End If
  40.    
  41.     With Application
  42.         .ScreenUpdating = True
  43.         .DisplayAlerts = True
  44.         .EnableEvents = True
  45.         .Calculation = xlCalculationAutomatic
  46.     End With
  47.     MsgBox "提取完成"
  48.     Exit Sub
  49.    
  50. ErrorHandler:
  51.     MsgBox Err.Number & vbCrLf & Err.Description

  52.     With Application
  53.         .ScreenUpdating = True
  54.         .DisplayAlerts = True
  55.         .EnableEvents = True
  56.         .Calculation = xlCalculationAutomatic
  57.     End With
  58. End Sub
复制代码
回复

使用道具 举报

发表于 2013-7-20 20:04 | 显示全部楼层
示例.rar (12.05 KB, 下载次数: 11)
回复

使用道具 举报

发表于 2013-7-20 20:07 | 显示全部楼层
fp$ = ThisWorkbook.Path & "\"
fn$ = Dir(fp & "*.xls")
i = 2
Do While fn <> ""
    If fn <> "示例.xls" Then
      Cells(i, 1) = Left(fn, Len(fn) - 4)
      Cells(i, 2) = "='" & fp & "\[" & fn & "]Sheet1'!$E$22"
      i = i + 1
    End If
    fn = Dir
Loop
Range("b2:b" & i - 1) = Range("b2:b" & i - 1).Value
回复

使用道具 举报

发表于 2013-7-20 20:15 | 显示全部楼层
  1. Sub 数据的提取()
  2. Range("a2:b" & [a65536].End(3).Row + 1).ClearContents
  3. Application.DisplayAlerts = False
  4. mp = ThisWorkbook.Path & ""
  5. mf = Dir(mp & "*.xls")
  6. n = 1
  7. Do While mf <> ThisWorkbook.Name
  8. Set dk = Workbooks.Open(mp & mf)
  9. n = n + 1
  10. m = Application.Find(".", dk.Name)
  11. Cells(n, 1) = Left(dk.Name, Application.Find(".", dk.Name) - 1)
  12. Cells(n, 2) = dk.Sheets(1).[e22]
  13. dk.Close
  14. mf = Dir
  15. Loop
  16. Application.DisplayAlerts = True
  17. End Sub
复制代码
回复

使用道具 举报

发表于 2013-7-20 20:16 | 显示全部楼层
本帖最后由 zjdh 于 2013-7-20 20:18 编辑
  1. Sub TEST()
  2.     Application.ScreenUpdating = False
  3.     On Error Resume Next
  4.     With ActiveSheet
  5.         For I = 2 To .Range("A65536").End(3).Row
  6.             Set BK = Workbooks.Open(ThisWorkbook.Path & "" & Cells(I, 1).Value & ".xls")
  7.             If Not BK Is Nothing Then .Cells(I, 2) = BK.Sheets(1).Range("E22")
  8.             BK.Close False
  9.             Set BK = Nothing
  10.         Next
  11.     End With
  12.     Application.ScreenUpdating = True
  13.     MsgBox "数据汇总完毕!"
  14. End Sub
复制代码

评分

参与人数 1 +1 收起 理由
maicao1986 + 1 赞一个!

查看全部评分

回复

使用道具 举报

发表于 2013-7-20 20:25 | 显示全部楼层
示例1.rar (9.8 KB, 下载次数: 3)
回复

使用道具 举报

发表于 2013-7-20 20:58 | 显示全部楼层
本帖最后由 w2001pf 于 2013-7-20 20:59 编辑
hwc2ycy 发表于 2013-7-20 20:02

花了半个多小时才基本读懂花花老师写的眼花缭乱的代码。可惜记不住的。strFile = Dir为什么要写这句代码,是什么意思 啊?
回复

使用道具 举报

发表于 2013-7-20 21:04 | 显示全部楼层
w2001pf 发表于 2013-7-20 20:58
花了半个多小时才基本读懂花花老师写的眼花缭乱的代码。可惜记不住的。strFile = Dir为什么要写这句代码, ...

我的没有按你的要求指定的文件名,我是直接遍历当前目录下的所有工作簿。
回复

使用道具 举报

发表于 2013-7-20 21:08 | 显示全部楼层
hwc2ycy 发表于 2013-7-20 21:04
我的没有按你的要求指定的文件名,我是直接遍历当前目录下的所有工作簿。

有几句代码的意思 请教老师: Len(strFile)这句与strFile = Dir为什么要写?是什么意思?
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-28 19:25 , Processed in 0.372025 second(s), 16 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表