求助一个问题 如图 需要一串代码

随手写了下，没验证，你试试
Sub xxx()
Dim datenow, c, myrange, myrow, ws As Worksheet
Set ws = ThisWorkbook.Sheets(1)
c = ws.Range("a65500").End(xlUp).Row
For Each myrange In Range("a1:a" & c)
If myrange = Date Then
myrow = myrange.Row
Rows((myrow - 1) & ":" & (myrow - 3)).Select
Selection.EntireRow.Hidden = True
Exit Sub
End If
Next
End Sub

暖贴

在@Doult_跳 的基础上修改的，应该满足需求
Sub xxx()
Dim datenow, c, d, myrange, myrow, ws As Worksheet
Set ws = ThisWorkbook.Sheets(1)
c = ws.Range("a65500").End(xlUp).Row
'取消隐藏所有
Rows("2:65536").Select
Selection.EntireRow.Hidden = False
For Each myrange In Range("a1:a" & c)
If myrange = Date Then
myrow = myrange.Row
'Rows((myrow - 1) & ":" & (myrow - 3)).Select
'Selection.EntireRow.Hidden = True
Rows("2:" & (myrow - 7)).Select
Selection.EntireRow.Hidden = True
Rows((myrow) & ":" & c).Select
Selection.EntireRow.Hidden = True
Exit Sub
End If
Next
End Sub

Cells.Select '选中所有单元格
Selection.EntireRow.Hidden = False '取消所有隐藏
c = Range("a65500").End(xlUp).Row '取A列非空行标，赋值给c
Set Rg = Columns(1).Find(Date) '在第一列中匹配当天日期
If Rg Is Nothing Then
MsgBox "无匹配到指定日期"
Else
If Rg.Row > 3 Then '如果当天日期小于3号，则不能显示三天内容
Rows(Rg.Row & ":" & c).EntireRow.Hidden = True
Rows("2:" & Rg.Row - 4).EntireRow.Hidden = True
Else
Rows(Rg.Row & ":" & c).EntireRow.Hidden = True
End If
End If