VBA提取指定文件夹下的excel文件名及内容运行报错

morningdylan · 发表于 2021-5-8 23:57

运行错误是1004程序如下请大家帮忙，谢谢。
Sub find()
Application.ScreenUpdating = False
Dim Mydir As String
Dim i As Integer
i = 2
Mydir = "E:\新建文件夹"
ChDrive Left(Mydir, 1)
ChDir Mydir
Match = Dir$("*.xls")
Do
If Not LCase(Match) = LCase(ThisWorkbook.Name) Then
Workbooks.Open Match, 0, 1
ThisWorkbook.ActiveSheet.Range("A" & i) = Match
ThisWorkbook.ActiveSheet.Range("C" & i) = ActiveWorkbook.Sheets("Sheet1").Range("B2")
ThisWorkbook.ActiveSheet.Range("D" & i) = ActiveWorkbook.Sheets("Sheet1").Range("C2")
ThisWorkbook.ActiveSheet.Range("E" & i) = ActiveWorkbook.Sheets("Sheet1").Range("B3")
ThisWorkbook.ActiveSheet.Range("F" & i) = ActiveWorkbook.Sheets("Sheet1").Range("C3")
ThisWorkbook.ActiveSheet.Range("G" & i) = ActiveWorkbook.Sheets("Sheet1").Range("B4")
ThisWorkbook.ActiveSheet.Range("H" & i) = ActiveWorkbook.Sheets("Sheet1").Range("B4")
ThisWorkbook.ActiveSheet.Range("I" & i) = ActiveWorkbook.Sheets("Sheet1").Range("B4")
ThisWorkbook.ActiveSheet.Range("J" & i) = ActiveWorkbook.Sheets("Sheet1").Range("B4")
ThisWorkbook.ActiveSheet.Range("K" & i) = ActiveWorkbook.Sheets("Sheet1").Range("B4")
ThisWorkbook.ActiveSheet.Range("L" & i) = ActiveWorkbook.Sheets("Sheet1").Range("B4")
ThisWorkbook.ActiveSheet.Range("M" & i) = ActiveWorkbook.Sheets("Sheet1").Range("B4")
ThisWorkbook.ActiveSheet.Range("N" & i) = ActiveWorkbook.Sheets("Sheet1").Range("B4")
ActiveWorkbook.Close 0
i = i + 1
End If
Match = Dir$
Loop Until Len(Match) = 0
Application.ScreenUpdating = True
End Sub

morningdylan · 发表于 2021-5-9 00:07

信任中心宏设置都没有问题，请大神帮忙优化一下

3190496160 · 发表于 2021-5-9 10:50

这种问题更是应该上传附件才可能测试代码，查找原因的

morningdylan · 发表于 2021-5-9 11:13

3190496160 发表于 2021-5-9 10:50
这种问题更是应该上传附件才可能测试代码，查找原因的

我用家里电脑电脑运行就没问题，到公司就不行了始终找不到原因，帮忙看看语句有问题吗。

morningdylan · 发表于 2021-5-9 11:25

3190496160 发表于 2021-5-9 10:50
这种问题更是应该上传附件才可能测试代码，查找原因的

运行时下面这句报错
ChDir Mydir

morningdylan · 发表于 2021-5-9 11:29

有大神吗帮忙看看急急急

3190496160 · 发表于 2021-5-9 11:48

Sub find()
Application.ScreenUpdating = False
Dim i As Integer
Set sh = ThisWorkbook.ActiveSheet
i = 2
f = Dir("E:\新建文件夹\*.xls*")
Do While f <> ""
If f <> ThisWorkbook.Name Then
      Set wb = Workbooks.Open("E:\新建文件夹\" & f, 0)
      With wb.Worksheets(1)
         sh.Range("A" & i) = Split(f, ".")(0)
         sh.Range("C" & i) = .Range("B2")
         sh.Range("D" & i) = .Range("C2")
         sh.Range("E" & i) = .Range("B3")
         sh.Range("F" & i) = .Range("C3")
         sh.Range("G" & i) = .Range("B4")
         sh.Range("H" & i) = .Range("B4")
         sh.Range("I" & i) = .Range("B4")
         sh.Range("J" & i) = .Range("B4")
         sh.Range("K" & i) = .Range("B4")
         sh.Range("L" & i) = .Range("B4")
         sh.Range("M" & i) = .Range("B4")
         sh.Range("N" & i) = .Range("B4")
      End With
      wb.Close False
      i = i + 1
End If
f = Dir
Loop
Application.ScreenUpdating = True
MsgBox "ok!", 64, "提醒"
End Sub

3190496160 · 发表于 2021-5-9 11:49

新建 Microsoft Excel 工作表.rar (5.67 KB, 下载次数: 16)

3190496160 · 发表于 2021-5-9 11:49

一直舍不得上传你那点东西，生怕别人把你拿走？？自己试试看看吧，没有附件没法测试

morningdylan · 发表于 2021-5-9 13:02

本帖最后由 morningdylan 于 2021-5-9 18:16 编辑

3190496160 发表于 2021-5-9 11:49
一直舍不得上传你那点东西，生怕别人把你拿走？？自己试试看看吧，没有附件没法测试

不是我们公司电脑里的文件只进不出我也想发给你

		自动登录	找回密码
密码			免费注册