Sub 更新数据1_Click()
'1.获取单个文件
Dim strFile As string
strFile = GetSingleFileName
If strFile = "" Then
Exit Sub
End if
'2.打开单个文件
Application.DisplayAlerts = FAlse '关闭各种警告和消息，选择默认应答
Dim Fso As Object
Set Fso = CreateObject("Scipting.FileSystemObject")
WorkBooks.Open (strFile)
Set Fso = Nothing
Application.DisplayAlerts = True
'查找a列第一个为数字的地址
Dim ARng As Range
Dim curSheet As String
curSheet = "Sheet1"
Dim deepRow As Integer
Dim lenRow As Integer
Dim thickRow As Integer
Dim cmpRng As Range
'从上往下更新查找
for i = 1 to [A65536].End(xlUp).Row
if Application.IsNumber(ActiveSheet.Cells(i, 1)) = True Then
'熔深数据比较
deepRow = Cells(i, 1).Row
CmpValue deepRow, 1
'脚长比较
lenRow = deepRow + 2
CmpValue lenRow, 1
‘厚度比较
thickRow = lenRow + 2
Cmpvalue thickRow, 0
End if
Next
End Sub
private Function GetSingleFileName()
Dim sFile As String
sFile = Application.GetOpenFilename( _
fileFilter:="xlsx (*.xlsx), *.xlsx", _
Title:= "选择要更新的Excel文件"
if sFile = CStr(Fasle) then
’没有选择文件
GetSingleFileName = ""
Else
GetSingleFileName = sFile
End if
End Function
Private Function Cmpvalue(ByVal deepRow As integer, ByVal rowCount As integer)
Dim deepRow As Range
Set deepRow = Range("F" & deepRow & ":Q" & (deepRow + rowCount))
deepRng.Select
'D列数据必须为数字，必须大于0
if application.IsNumber(ActiveSheet.Cells(deepRow, "D")) = True Then
if Cells(deepRow, "D").Value <= 0# then
Exit Function
End if
End if
for each r in selection
'不为空值则比较大小
if r.value <> "" Then
'比较数值
if r.value < Cells(deepRow, "D") Then
'不符合条件的设置为黄色
r.Interior.ColorIndex = 6
Else
'设置回白色
r.interior.ColorIndex = 2
End if
End if
Next
End Function