复制代码 代码如下: 'This code is done by KangKang@ Option explicit ‘This is optional, but better to use. Dim FolderPath,Folder Dim fso,File,Files Dim fileNums Dim FileString() Dim i Dim ii
i=0 FolderPath="E:/TDDOWNLOAD/aa/"
'**********************1.To create the FileSystemObject object******************************** Set fso= CreateObject("Scripting.FileSystemObject")'This is the way to create FileSystemObjecy ‘这句话在Excel VBA中也可以如此定义来引用FSO! 'Scripting是类库的名字,filesystemobject是所引用的对 '象, 说明了此时VBA所用的对象不是自带的，而是引用 '外界的。
'**********************2.To create the Folder and File object********************************* If fso.FolderExists(FolderPath) Then Set Folder = fso.GetFolder(FolderPath) 'This set command is neccessary! Set Files=Folder.Files fileNums=Files.Count 'Msgbox fileNums For Each File In Folder.Files if right(File.name,2)="rm" then ReDim Preserve FileString(i) 'This is a Dynamic Array, so we should use the Redim command 'Be careful of the Preserve word, important!!!! FileString(i)=File.Name 'MsgBox i & " " & FileString(i) i=i+1 fileNums=i End if Next End If
'**********************3.Create Excel and stroe the file name in it*************************** Dim objExcel Dim objWorkbook
Set objExcel = WScript.CreateObject("Excel.Application") objExcel.Workbooks.Add objExcel.Visible=True
Set objWorkbook = objExcel.ActiveWorkbook For ii=1 to fileNums objWorkbook.Worksheets(1).Cells(ii,1)=FileString(ii-1) Next objWorkbook.Worksheets(1).Range("A1:A1").Columns.AutoFit objExcel.DisplayAlerts = False objWorkbook.SaveAs(FolderPath & "xiao.xls")
objWorkbook.Close()'Close the Workbook objExcel.Quit()'Quit Set fso=Nothing
'**********************4.Open the files and read the first line.****************************** Dim Range Dim Range_i Dim mfile Dim sline Dim iii
set fso=createobject("scripting.filesystemobject") Set objExcel = WScript.CreateObject("Excel.Application") objExcel.Visible=True objExcel.Workbooks.open(FolderPath & "xiao.xls")
Set objWorkbook = objExcel.ActiveWorkbook Set Range = objWorkbook.Activesheet.range("A1:A11")
For Range_i=1 to fileNums set mfile=fso.opentextfile(Range(Range_i).html' target='_blank'>value) msgbox Range_i & " " & Range(Range_i).value for iii=1 to 1 sline=mfile.readline objWorkbook.Worksheets(1).Cells(Range_i,2)=sline Next mfile.close Next objWorkbook.Worksheets(1).Range("B1:B1").Columns.AutoFit objExcel.DisplayAlerts = False objWorkbook.SaveAs(FolderPath & "xiao.xls")
objWorkbook.Close()'Close the Workbook objExcel.Quit()'Quit Set fso=Nothing
