vba 数据更新

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