|
'仅测试于windows2002 + office2003 '勾选工具、引用Miscosoft Excel 11.0 Object libaray
Sub 孤独一叶()
'代码主要部分是原来老大的
Dim MyDialog As FileDialog, vrtSelectedItem As Variant
Dim aexcel As Excel.Application, axls As Excel.Workbook
Dim ast As String
On Error GoTo hander:
'On Error Resume Next
'定义一个文件夹选取对话框
Set MyDialog = Application.FileDialog(msoFileDialogFilePicker)
With MyDialog
.Filters.Clear '清除所有文件筛选器中的项目
.Filters.Add "所有 xls文件", "*.xls", 1 '增加筛选器的项目为所有WORD文件
.AllowMultiSelect = False '不允许多项选择
If .Show = -1 Then '确定
Set aexcel = CreateObject("Excel.Application")
Application.ScreenUpdating = False
For Each vrtSelectedItem In .SelectedItems '在所有选取项目中循环
ast = vrtSelectedItem
aexcel.Visible = False
Set axls = aexcel.Workbooks.Open(vrtSelectedItem)
With axls
Dim bb As Long
Dim bbvr1, eevr1, hhvr1
bb = .Worksheets("8t").Range("b65536").End(xlUp).Row
Set bbvr1 = .Worksheets("8t").Range("b5:b" & bb)
Set eevr1 = .Worksheets("8t").Range("e5:e" & bb)
Set hhvr1 = .Worksheets("8t").Range("h5:h" & bb)
End With
Next vrtSelectedItem
End If
End With
Application.ScreenUpdating = True
Dim astring, a As Long
For a = 1 To bb - 5+1
'ui03001<<TAB>>8t<<F2>>0<<F8>><<enter>>
'<<SECS12>>
astring = astring & bbvr1(a) & "<<TAB>>" & eevr1(a) & "<<F2>>" & hhvr1(a) & "<<F8>><<enter>>" & Chr(13) & "<<SECS12>>" & Chr(13)
Next
Dim fso, MyFile
ast = Replace(ast, "xls", "txt")
Set fso = CreateObject("Scripting.FileSystemObject")
Set MyFile = fso.CreateTextFile(ast, True)
MyFile.Write (astring)
MyFile.Close
aexcel.Quit '释放变量
MsgBox "已完成，请核对！"
Exit Sub
hander:
aexcel.Quit '释放变量
MsgBox "请再检查一次，是否是我错了？：）"
End Sub
[此贴子已经被作者于2006-4-14 20:01:50编辑过] | 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2006-4-14 15:47
发表于 2006-4-14 19:58
楼主
