有偿请高手帮写个vba
vba吧
全部回复
仅看楼主
level 1
说明:请高手帮写个vba,根据B列判断移植或剪枝对应规则计算D列树苗每周期移植和剪枝日期以及E列剩余天数,
本人新手小白,拜托了,无比感谢!
移植规则为按种植日期算第6年移植一次,然后第十年起每年移植一次,
剪枝规则为按种植日期算每年剪枝一次,然后第五年后半年剪枝一次,
求出D列为到期日,定为该月的最后一天,再求出E列为剩余天数,则E列减今天日期算出或用别的方式算出
本人v,csliumu
2026年01月31日 19点01分 1
level 12
Sub 计算移剪日期和剩余天数()
Dim ws As Worksheet
Dim lastRow As Long
Dim i As Long
Dim 种植日期 As Date
Dim 移剪到期日 As Date
Dim 剩余天数 As Long
Dim 今天日期 As Date
' 设置当前工作表
Set ws = ThisWorkbook.Worksheets("工作表1")
' 获取今天的日期
今天日期 = Date
' 获取数据的最后一行
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' 从第4行开始遍历数据行
For i = 4 To lastRow
' 先判断种植日期单元格是否为空
If IsDate(ws.Cells(i, "C").Value) Then
种植日期 = ws.Cells(i, "C").Value
' 根据B列判断是移植还是剪枝
Select Case Trim(ws.Cells(i, "B").Value)
Case "移植"
' 移植规则:第6年移植一次,第10年起每年移植
If DateDiff("yyyy", 种植日期, 今天日期) < 6 Then
' 未满6年,到期日为种植日期+6年,且为该月最后一天
移剪到期日 = DateSerial(Year(种植日期) + 6, Month(种植日期) + 1, 0)
ElseIf DateDiff("yyyy", 种植日期, 今天日期) < 10 Then
' 6-10年之间,到期日为种植日期+10年,且为该月最后一天
移剪到期日 = DateSerial(Year(种植日期) + 10, Month(种植日期) + 1, 0)
Else
' 满10年,到期日为今年的种植月份最后一天
移剪到期日 = DateSerial(Year(今天日期), Month(种植日期) + 1, 0)
' 如果今年的日期已过,则自动顺延到明年
If 移剪到期日 < 今天日期 Then
移剪到期日 = DateSerial(Year(今天日期) + 1, Month(种植日期) + 1, 0)
End If
End If
Case "剪枝"
' 剪枝规则:前5年每年一次,第5年后半年一次
If DateDiff("yyyy", 种植日期, 今天日期) < 5 Then
' 未满5年,到期日为今年的种植月份最后一天
移剪到期日 = DateSerial(Year(今天日期), Month(种植日期) + 1, 0)
' 如果今年的日期已过,则自动顺延到明年
If 移剪到期日 < 今天日期 Then
移剪到期日 = DateSerial(Year(今天日期) + 1, Month(种植日期) + 1, 0)
End If
Else
' 满5年,半年剪一次
If Month(今天日期)
2026年02月01日 01点02分 3
level 12
' 满5年,半年剪一次
If Month(今天日期) <= Month(种植日期) Then
' 上半年:到期日为今年种植月份最后一天
移剪到期日 = DateSerial(Year(今天日期), Month(种植日期) + 1, 0)
Else
' 下半年:到期日为今年种植月份+6个月的最后一天
移剪到期日 = DateSerial(Year(今天日期), Month(种植日期) + 7, 0)
' 若计算出的月份超过12,自动跨年
If Month(移剪到期日) > 12 Then
移剪到期日 = DateSerial(Year(移剪到期日) + 1, Month(移剪到期日) - 12, 0)
End If
End If
End If
End Select
' 写入移剪到期日到D列
网页链接 (i, "D").Value = 移剪到期日
' 计算剩余天数并写入E列
剩余天数 = DateDiff("d", 今天日期, 移剪到期日)
ws.Cells(i, "E").Value = 剩余天数
End If
Next i
' 格式化日期列和数字列
ws.Columns("D").NumberFormat = "yyyy/m/d"
ws.Columns("E").NumberFormat = "0"
MsgBox "计算完成!", vbInformation
End Sub
2026年02月01日 01点02分 4
已加v,上面是豆包ai的,我希望你发一份文件给我测试一下,通常会有些地方需要修改
2026年02月01日 01点02分
AI呀,很轻松
2026年02月01日 06点02分
level 1
举手之劳不要钱
2026年02月01日 05点02分 5
1