Private Sub Command1_Click() '定义、声明EXCEL对象
Dim xlapp As Excel.Application
Dim xlbook As Excel.Workbook
Dim xlsheet As Excel.Worksheet Set xlapp = New Excel.Application
'选定EXCEL文件路径传递
If Right(File1.Path, 1) <> "\" Then
FileName1 = File1.Path + "\" + File1.FileName
Else
FileName1 = File1.Path + File1.FileName
End If
'打开需转换的EXCEL Set xlbook = xlapp.Workbooks.Open(FileName1)
xlapp.Visible = False'判断“实测大断面成果表”
Dim n, c As Integer
Dim sign As Boolean
If Option1(0).Value = True Then'运行第二遍时停在这个地方
’报错信息为“实时错误462:远程服务器不存在或不能使用
If Right(Range(Cells(1, 1), Cells(1, 1)), 7) = "实测流量成果表" Then
n = ActiveSheet.Range(Cells(65535, 1), Cells(65535, 1)).End(xlUp).Row '计算总行数
c = 0 '合计出错处
For i = 6 To n
If Val(Range(Cells(i, 1), Cells(i, 1))) <> 0 Then
'月日检查
'起止时:分检查
Dim hour1, hour2, min1, min2 As Integer hour1 = Val(Range(Cells(i, 4), Cells(i, 4)))
hour2 = Val(Range(Cells(i, 5), Cells(i, 5)))
min1 = Val(Right(Range(Cells(i, 4), Cells(i, 4)), 2))
min2 = Val(Right(Range(Cells(i, 5), Cells(i, 5)), 2))
sign = False
If hour1 > 24 Or hour2 > 24 Then sign = True
If min1 > 60 Or min1 > 60 Then sign = True
If hour1 > 20 And hour2 < 5 Then hour2 = hour2 + 24
If hour1 = hour2 And min1 >= min2 Then sign = True
If hour1 > hour2 Then sign = True
If Abs(hour2 - hour1) > 5 Then sign = True
If sign = True Then
Range(Cells(i, 4), Cells(i, 5)).Select
Selection.Font.ColorIndex = 3
c = c + 1
End If
'"流速"平均值与最大值检查
Dim v1, v2 As Single
sign = False
v1 = Val(Range(Cells(i, 11), Cells(i, 11)))
v2 = Val(Range(Cells(i, 12), Cells(i, 12)))
If v1 >= v2 Then sign = True
If sign = True Then
Range(Cells(i, 11), Cells(i, 12)).Select
Selection.Font.ColorIndex = 3
c = c + 1
End If
'"水深"平均值与最大值检查
Dim d1, d2 As Single
sign = False
d1 = Val(Range(Cells(i, 14), Cells(i, 14)))
d2 = Val(Range(Cells(i, 15), Cells(i, 15)))
If d1 >= d2 Then sign = True
If sign = True Then
Range(Cells(i, 14), Cells(i, 15)).Select
Selection.Font.ColorIndex = 3
c = c + 1
End If
'糙率检查
If Range(Cells(i, 16), Cells(i, 16)) <> "" Then
Dim s, n0 As Double
sign = False
s = Val(Range(Cells(i, 16), Cells(i, 16))) / 10000
n0 = Round((d1 ^ (2 / 3)) * (s ^ (1 / 2)) / v1, 3)
If n0 <> Val(Range(Cells(i, 17), Cells(i, 17))) Then sign = True
If sign = True Then
Range(Cells(i, 17), Cells(i, 17)).Select
Selection.Font.ColorIndex = 3
c = c + 1
End If
End If
End If
Next i
If c = 0 Then
return_value = MsgBox("未发现错误!", 48, "检查结束")
Else
return_value = MsgBox("发现" & c & "处错误!", 48, "检查结束")
End If
Else
return_value = MsgBox("此表非实测流量成果表", 16, "错误")
End If
End If
'关闭当前EXCLE表
xlapp.DisplayAlerts = False '不提示保存
xlbook.Close
xlapp.Quit
Set xlsheet = Nothing
Set xlbook = Nothing
Set xlapp = Nothing
Shell "taskkill /im EXCEL.exe /f", vbHide '强行杀EXCEL.EXE进程 '============关闭对象==============
Set xlsheet = Nothing
'Workbook 和 Application 应该分别处理
If Not xlbook Is Nothing Then
xlbook.Close
Set xlbook = Nothing
End If
If Not xlapp Is Nothing Then
xlapp.Quit
Set xlapp = Nothing
End IfEnd Sub不知道用哪种方法,就用了各种结束EXCEL.EXE的方法,但还是不奏效。。
遂请VB高手不吝赐教,小弟在这谢谢了。
Dim xlapp As Excel.Application
Dim xlbook As Excel.Workbook
Dim xlsheet As Excel.Worksheet Set xlapp = New Excel.Application
'选定EXCEL文件路径传递
If Right(File1.Path, 1) <> "\" Then
FileName1 = File1.Path + "\" + File1.FileName
Else
FileName1 = File1.Path + File1.FileName
End If
'打开需转换的EXCEL Set xlbook = xlapp.Workbooks.Open(FileName1)
xlapp.Visible = False'判断“实测大断面成果表”
Dim n, c As Integer
Dim sign As Boolean
If Option1(0).Value = True Then'运行第二遍时停在这个地方
’报错信息为“实时错误462:远程服务器不存在或不能使用
If Right(Range(Cells(1, 1), Cells(1, 1)), 7) = "实测流量成果表" Then
n = ActiveSheet.Range(Cells(65535, 1), Cells(65535, 1)).End(xlUp).Row '计算总行数
c = 0 '合计出错处
For i = 6 To n
If Val(Range(Cells(i, 1), Cells(i, 1))) <> 0 Then
'月日检查
'起止时:分检查
Dim hour1, hour2, min1, min2 As Integer hour1 = Val(Range(Cells(i, 4), Cells(i, 4)))
hour2 = Val(Range(Cells(i, 5), Cells(i, 5)))
min1 = Val(Right(Range(Cells(i, 4), Cells(i, 4)), 2))
min2 = Val(Right(Range(Cells(i, 5), Cells(i, 5)), 2))
sign = False
If hour1 > 24 Or hour2 > 24 Then sign = True
If min1 > 60 Or min1 > 60 Then sign = True
If hour1 > 20 And hour2 < 5 Then hour2 = hour2 + 24
If hour1 = hour2 And min1 >= min2 Then sign = True
If hour1 > hour2 Then sign = True
If Abs(hour2 - hour1) > 5 Then sign = True
If sign = True Then
Range(Cells(i, 4), Cells(i, 5)).Select
Selection.Font.ColorIndex = 3
c = c + 1
End If
'"流速"平均值与最大值检查
Dim v1, v2 As Single
sign = False
v1 = Val(Range(Cells(i, 11), Cells(i, 11)))
v2 = Val(Range(Cells(i, 12), Cells(i, 12)))
If v1 >= v2 Then sign = True
If sign = True Then
Range(Cells(i, 11), Cells(i, 12)).Select
Selection.Font.ColorIndex = 3
c = c + 1
End If
'"水深"平均值与最大值检查
Dim d1, d2 As Single
sign = False
d1 = Val(Range(Cells(i, 14), Cells(i, 14)))
d2 = Val(Range(Cells(i, 15), Cells(i, 15)))
If d1 >= d2 Then sign = True
If sign = True Then
Range(Cells(i, 14), Cells(i, 15)).Select
Selection.Font.ColorIndex = 3
c = c + 1
End If
'糙率检查
If Range(Cells(i, 16), Cells(i, 16)) <> "" Then
Dim s, n0 As Double
sign = False
s = Val(Range(Cells(i, 16), Cells(i, 16))) / 10000
n0 = Round((d1 ^ (2 / 3)) * (s ^ (1 / 2)) / v1, 3)
If n0 <> Val(Range(Cells(i, 17), Cells(i, 17))) Then sign = True
If sign = True Then
Range(Cells(i, 17), Cells(i, 17)).Select
Selection.Font.ColorIndex = 3
c = c + 1
End If
End If
End If
Next i
If c = 0 Then
return_value = MsgBox("未发现错误!", 48, "检查结束")
Else
return_value = MsgBox("发现" & c & "处错误!", 48, "检查结束")
End If
Else
return_value = MsgBox("此表非实测流量成果表", 16, "错误")
End If
End If
'关闭当前EXCLE表
xlapp.DisplayAlerts = False '不提示保存
xlbook.Close
xlapp.Quit
Set xlsheet = Nothing
Set xlbook = Nothing
Set xlapp = Nothing
Shell "taskkill /im EXCEL.exe /f", vbHide '强行杀EXCEL.EXE进程 '============关闭对象==============
Set xlsheet = Nothing
'Workbook 和 Application 应该分别处理
If Not xlbook Is Nothing Then
xlbook.Close
Set xlbook = Nothing
End If
If Not xlapp Is Nothing Then
xlapp.Quit
Set xlapp = Nothing
End IfEnd Sub不知道用哪种方法,就用了各种结束EXCEL.EXE的方法,但还是不奏效。。
遂请VB高手不吝赐教,小弟在这谢谢了。
ActiveSheet.Range
要修改成 xlapp.ActiveSheet.Range
Range(Cells(i, 14), Cells(i, 15)).Select
也要修改成xlsheet.Range(Cells(i, 14), Cells(i, 15)).Select
类似的地方都要修改。要不然就会出现第一次正常运行,第二次运行不了的情况。
Dim xlapp As Excel.Application
Dim xlbook As Excel.Workbook
Dim xlsheet As Excel.Worksheet你定义的这三个东西,根本就没有用到。怎么会对呢?我说的修改也不一定对,我也没试。你代码中的操作一定要对当前对象操作。
像这个
Range(Cells(i, 11), Cells(i, 12)).Select
一定要对你声明的对象进行操作
xlsheet.Range(Cells(i, 14), Cells(i, 15)).Select你就照着这个思路走。
Command1.Enabled = False
执行完任务
Command1.Enabled = True
------------------------------------------Private Sub Command1_Click()
Command1.Enabled = False
'定义、声明EXCEL对象
Dim xlapp As Excel.Application
Dim xlbook As Excel.Workbook
Dim xlsheet As Excel.Worksheet Set xlapp = New Excel.Application
' 选定EXCEL文件路径传递
If Right(File1.Path, 1) <> "\" Then
FileName1 = File1.Path + "\" + File1.FileName
Else
FileName1 = File1.Path + File1.FileName
End If
'打开需转换的 EXCEL Set xlbook = xlapp.Workbooks.Open(FileName1)
xlapp.Visible = False'判断“实测大断面成果表”
Dim n, c As Integer
Dim sign As Boolean
If Option1(0).Value = True Then'运行第二遍时停在这个地方
’报错信息为“实时错误462:远程服务器不存在或不能使用
If Right(Range(Cells(1, 1), Cells(1, 1)), 7) = "实测流量成果表" Then
n = ActiveSheet.Range(Cells(65535, 1), Cells(65535, 1)).End(xlUp).Row '计算总行数
c = 0 '合计出错处
For i = 6 To n
If Val(Range(Cells(i, 1), Cells(i, 1))) <> 0 Then
'月日检查
'起止时:分检查
Dim hour1, hour2, min1, min2 As Integer hour1 = Val(Range(Cells(i, 4), Cells(i, 4)))
hour2 = Val(Range(Cells(i, 5), Cells(i, 5)))
min1 = Val(Right(Range(Cells(i, 4), Cells(i, 4)), 2))
min2 = Val(Right(Range(Cells(i, 5), Cells(i, 5)), 2))
sign = False
If hour1 > 24 Or hour2 > 24 Then sign = True
If min1 > 60 Or min1 > 60 Then sign = True
If hour1 > 20 And hour2 < 5 Then hour2 = hour2 + 24
If hour1 = hour2 And min1 >= min2 Then sign = True
If hour1 > hour2 Then sign = True
If Abs(hour2 - hour1) > 5 Then sign = True
If sign = True Then
Range(Cells(i, 4), Cells(i, 5)).Select
Selection.Font.ColorIndex = 3
c = c + 1
End If
'"流速"平均值与最大值检查
Dim v1, v2 As Single
sign = False
v1 = Val(Range(Cells(i, 11), Cells(i, 11)))
v2 = Val(Range(Cells(i, 12), Cells(i, 12)))
If v1 >= v2 Then sign = True
If sign = True Then
Range(Cells(i, 11), Cells(i, 12)).Select
Selection.Font.ColorIndex = 3
c = c + 1
End If
'"水深"平均值与最大值检查
Dim d1, d2 As Single
sign = False
d1 = Val(Range(Cells(i, 14), Cells(i, 14)))
d2 = Val(Range(Cells(i, 15), Cells(i, 15)))
If d1 >= d2 Then sign = True
If sign = True Then
Range(Cells(i, 14), Cells(i, 15)).Select
Selection.Font.ColorIndex = 3
c = c + 1
End If
'糙率检查
If Range(Cells(i, 16), Cells(i, 16)) <> "" Then
Dim s, n0 As Double
sign = False
s = Val(Range(Cells(i, 16), Cells(i, 16))) / 10000
n0 = Round((d1 ^ (2 / 3)) * (s ^ (1 / 2)) / v1, 3)
If n0 <> Val(Range(Cells(i, 17), Cells(i, 17))) Then sign = True
If sign = True Then
Range(Cells(i, 17), Cells(i, 17)).Select
Selection.Font.ColorIndex = 3
c = c + 1
End If
End If
End If
Next i
If c = 0 Then
return_value = MsgBox("未发现错误!", 48, "检查结束")
Else
return_value = MsgBox("发现" & c & "处错误!", 48, "检查结束")
End If
Else
return_value = MsgBox("此表非实测流量成果表", 16, "错误")
End If
End If'关闭当前EXCLE表
xlapp.DisplayAlerts = False '不提示保存
xlbook.Close
xlapp.Quit
Set xlsheet = Nothing
Set xlbook = Nothing
Set xlapp = Nothing
Command1.Enabled = True
End Sub