求助VBA实现到期提醒

如果你需要一打开这个Excel文件就自动判断，那么新建一个模块，然后输入

Sub auto_open()

With Sheets("sheet1")

Dim tToday As Date

tToday = Date

Dim rRan As Range

Set rRan = .Cells(1, 1)

Do While rRan.Value <>""

.Rows(rRan.Row).Interior.Pattern = xlNone

Dim strTemp As String

strTemp = rRan.Offset(0, 1).Value

If tToday >= rRan.Value And rRan.Offset(0, 1) = "" Then

.Rows(rRan.Row).Interior.Pattern = xlSolid

.Rows(rRan.Row).Interior.Color = 65535

End If

Set rRan = rRan.Offset(1, 0)

Loop

End With

End Sub

这样就行了

说实话没太配橡看懂你的问题要求，我写的程序是判断A列中的日期液冲是否小于等于今天（就是是否已经到期或者过期），并且判断B列中相应位置是否有输入内容来的。具体的实现过程有很多种，我是按照你的要求中最方便写的来的培埋旁，具体的实现你可以自己改，比如把offset换成其他的引用形式等等。

还有请注意，这段VBA是在Excel2007中实现的，如果是Excel2003，改变颜色的方法以及颜色的代码会略有不同，你可以自己录制一段宏来测试一下。

很多朋友会遇到这样的问题，就是很有很多页的数据，少的有几十页，多的可能有几百页，然后需要合并到一个页面做缓册数据分析，如果一页页的复制粘贴的话，就比较麻烦。下面我就介绍一种利用Excel的宏计算来解决这个问题。

1 数据准备

如图，以6个sheet为例，每个表中都是同样结构的数据，行数不确定。现在需要将各月数据汇总到汇总表中。

2 复制代码

在汇总表的标签点“右键”，找到“查看代码”，然后看到宏计算界面。如图所示：

会看到代码输入的界面：

复制下面这段代码到空白区域：

Sub 合并当前工作簿下的所有工作表()

Application.ScreenUpdating = False

For j = 1 To Sheets.Count

If Sheets(j).Name <>ActiveSheet.Name Then

X = Range('A65536').End(xlUp).Row 1

Sheets(j).UsedRange.Copy Cells(X, 1)

End If

Next

Range('B1').Select

Application.ScreenUpdating = True

MsgBox '当前工作簿下的全部工作表已经合并完毕！', vbInformation, '提示'

End Sub

效果如图：

3 执行代码完成合并

做完上面的事情，然后只需要点击工具栏上面的“运行”下的“运行子过程/用户窗体”就可以了：

合并完之后会有提示。提示完成之后就可以把宏计算野蔽界面关闭了。如图所示：

点击确定，关闭代码窗口：

可以扰脊宏看到数据已经完成了合并，如果不需要标题的话，筛选删除即可。

---