VB打开一个文件夹下所有的excel并且对其进行读取操作

Question

VB打开一个文件夹下所有的excel并且对其进行读取操作，自己实现了一部分代码，可是总是提示出错。自己通过监视发现，如果用do while 语句，打开excel的时候其文件名数组为空的了。如果用for循环的话，总是报 实时错误9 超出下标，通过监视也找不到问题所在。
代码如下，希望高手朋友帮忙看看，解答一下
窗体上有drivelistbox控件、dirlistbox控件、filelistbox控件、text控件和一个command空间
Private Sub command1_Click()
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim i As Integer
Dim strfilenames As String

Text1.Text = ""
File1.Path = Dir1.List(Dir1.ListIndex) '指定一个文件夹
File1.Pattern = "*.xls" '指定文件类型

Call Co_CloseExcel '这是一个结束进程中的excel.exe的函数

Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
ReDim str(File1.ListCount)
For i = 0 To File1.ListCount - 1
str(i) = File1.List(i)
Next i

Do
strfilenames = File1.Path & "\" & str(i) ’这里出错了
Set xlBook = xlApp.Workbooks.Open(strfilenames) '打开已经存在的EXCEL工件簿文件
xlApp.Visible = False '设置EXCEL对象不可见
Set xlSheet = xlBook.Worksheets("sheet1") '设置活动工作表
xlSheet.Activate '激活工作表

'这里是我准备对打开的excel操作的代码

Text1.Text = Text1.Text & str(i) & "操作成功" & Chr(13) + Chr(10)
xlBook.Close (True) '关闭工作簿
Loop While str(i) = ""
xlApp.Quit '结束EXCEL对象
Set xlApp = Nothing '释放xlApp对象
Call Co_CloseExcel
MsgBox "处理完毕"
End Sub
Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub
Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub

Answer 1

进入Do时的i值已到了File1.ListCount，这时的str(i)并没有被赋值，当然会在strfilenames = File1.Path & "\" & str(i) ’这里出错了!!!

解决如下：

Do 循环可以并入到前一个For循环中

For i = 0 To File1.ListCount - 1
' str(i) = File1.List(i)
'Do '这里不需要了
strfilenames = File1.Path & "\" & File1.List(i) ’这里不需要数组str()了
Set xlBook = xlApp.Workbooks.Open(strfilenames) '打开已经存在的EXCEL工件簿文件
xlApp.Visible = False '设置EXCEL对象不可见
Set xlSheet = xlBook.Worksheets("sheet1") '设置活动工作表
xlSheet.Activate '激活工作表

'这里是我准备对打开的excel操作的代码

Text1.Text = Text1.Text & File1.List(i) & "操作成功" & Chr(13) + Chr(10)
xlBook.Close (True) '关闭工作簿
'Loop While str(i) = "" '这个也不需要了

Next i

Answer 2

在这里加一句
For i = 0 To File1.ListCount - 1
if i=file1.listcount-1 then exit for '在这里加一句
str(i) = File1.List(i)

strfilenames = File1.Path & "\" & str(i) ’这里出错了
Set xlBook = xlApp.Workbooks.Open(strfilenames)
'打开已经存在的EXCEL工件簿文件
xlApp.Visible = False '设置EXCEL对象不可见
Set xlSheet = xlBook.Worksheets("sheet1") '设置活动工作表
xlSheet.Activate '激活工作表

'这里是我准备对打开的excel操作的代码

Text1.Text = Text1.Text & str(i) & "操作成功" & Chr(13) + Chr(10)
xlBook.Close (True) '关闭工作簿
Next i

(别忘了采纳哟)

Answer 3

do循环中没有对 i 赋值、增值
--------------------
Do
strfilenames = File1.Path & "\" & str(i) ’这里出错了
Set xlBook = xlApp.Workbooks.Open(strfilenames) '打开已经存在的EXCEL工件簿文件
xlApp.Visible = False '设置EXCEL对象不可见
Set xlSheet = xlBook.Worksheets("sheet1") '设置活动工作表
xlSheet.Activate '激活工作表

'这里是我准备对打开的excel操作的代码

Text1.Text = Text1.Text & str(i) & "操作成功" & Chr(13) + Chr(10)
xlBook.Close (True) '关闭工作簿
Loop While str(i) = ""本回答被提问者采纳

Answer 4

'错误原因：Str是VB关键字，你把它当成了数组名称

'修改如下：
Private Sub command1_Click()
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim i As Integer
Dim strfilenames As String
Dim mStr() As String
Text1.Text = ""
File1.Path = Dir1.List(Dir1.ListIndex) '指定一个文件夹
File1.Pattern = "*.xls" '指定文件类型

Call Co_CloseExcel '这是一个结束进程中的excel.exe的函数

Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
ReDim mStr(File1.ListCount)
For i = 0 To File1.ListCount - 1
mStr(i) = File1.List(i)
Next i

Do
strfilenames = File1.Path & "\" & mStr(i) '这里出错了
Set xlBook = xlApp.Workbooks.Open(strfilenames) '打开已经存在的EXCEL工件簿文件
xlApp.Visible = False '设置EXCEL对象不可见
Set xlSheet = xlBook.Worksheets("sheet1") '设置活动工作表
xlSheet.Activate '激活工作表

'这里是我准备对打开的excel操作的代码

Text1.Text = Text1.Text & mStr(i) & "操作成功" & Chr(13) + Chr(10)
xlBook.Close (True) '关闭工作簿
Loop While mStr(i) = ""
xlApp.Quit '结束EXCEL对象
Set xlApp = Nothing '释放xlApp对象
Call Co_CloseExcel
MsgBox "处理完毕"
End Sub

Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub
Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub

Answer 5

重装系统吧，我以前也是这个毛病。