Question

我无法在Windows 7及更高版本上运行vbscript。此脚本主要用于将数据从一个Excel工作簿复制到另一个工作簿。请帮我。

感谢。

option explicit
on error resume next

dim objexcel,objfso,objfolder,objsubfolder,objfile,objrange
dim objworkbook,objworkbook2,objworksheet
dim strpath,pathname,endroww,introw,k,i
dim intnewrow,startrow,endrow
dim objrange1,objrange2

'constants asigned to sort
Const xlAscending = 1
Const xlYes = 1

Set objExcel = CreateObject("Excel.Application")

intnewrow=1

strPath = "C:\Documents and Settings\SupriyaS\Desktop\feb 141"
pathName="xls"

If strPath = "" then Wscript.quit
If pathName = "" then Wscript.quit

'Creating an Excel Workbook in My Documents(destination)
Set objWorkbook2= objExcel.Workbooks.Add()

'to supress the flashing oh the screens
objExcel.Visible = False

'to supress the dialog box
objExcel.DisplayAlerts = False

Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder (strPath)
Set objsubFolder = objfolder.subFolders
set objfile = objsubfolder.files

'loop through all the subfolders
For Each objsubfolder in objfolder.subfolders

'loopt hrough all the excel files in subfolder
For Each objFile In objsubFolder.Files

'to check for excel files using extention
If objFso.GetExtensionName (objFile.Path) = "xls" Then

'open the workbook to be copied from(source)
Set objWorkbook = objExcel.Workbooks.Open(objFile.Path)

'activate the worksheet
Set objWorksheet = objWorkbook.WorkSheets(1)
objworksheet.Activate

'copy from the 2nd row 
If intNewRow = 1 Then
startrow = 1
Else
startrow = 2
End If

'count the number of used row
endrow = objWorkbook.Worksheets("SHEET1").UsedRange.Rows.Count

'copy the data
objWorkbook.Worksheets("SHEET1").Range(startrow & ":" & endrow).Copy

'close the workbook after copying
objWorkbook.close

'paste it on workbook2
objWorkbook2.Worksheets("Sheet1").Cells(intNewRow,1).PasteSpecial

'increment the row
intNewRow = intNewRow + (endrow - startrow + 1)

End If
Next
Next

'counting row of workbook2
endroww = objWorkbook2.Worksheets("SHEET1").UsedRange.Rows.Count

'Deleting empty rows w.r.t column A (Sl.no)
while endroww >= 2   
if objworkbook2.worksheets("sheet1").cells(endroww,1).value = "" then 
Set objRange = objworkbook2.worksheets("sheet1").Cells(endroww,1).EntireRow
objrange.delete
end if 
endroww = endroww -1 
Wend   

'Sorting the data w.r.t date in ascending order
Set objWorksheet2 = objWorkbook2.Worksheets(1)
Set objRange1 = objWorksheet2.UsedRange
Header = xlYes
Set objRange2 = objExcel.Range("d2")
objRange2.Sort objRange2,xlAscending,,,,,,xlYes

'counting rows of workbook2 after deleting
k = objWorkbook2.Worksheets("SHEET1").UsedRange.Rows.Count

'Editing Serial number
introw = 2
for i = 1 to k
objworkbook2.worksheets("sheet1").cells(introw,1).value = i
introw = introw + 1
next

'save and close workbook2
objworkbook2.save
objworkbook2.close

这是脚本，它将循环遍历所有子文件夹，并将子文件夹中excel工作簿中的数据复制到单个工作簿。当我运行它运行的代码，但我没有得到例外输出，例如，它根本没有复制数据，我在运行代码时没有收到任何错误。

Answer 1

您需要注释掉该行。

on error resume next

通过

'on error resume next

然后，您将获得错误的错误号，行号和列数。

Answer 2

on error resume next

关闭错误检查。

如果您关闭错误检查，则需要自己完成。所以在任何可能产生错误的行之后

If err.number <> 0 then
    Fix_the_error
    err.clear
End If

无法在Windows 7及更高版本上运行vbscript

2 个答案: