高亮显示当日订单

将工作台帐优化一下，高亮显示当日订单，好处是工作完成度一目也然。

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Sh.Name Like "*月*日" Then
        Dim affectedRange As Range
        Set affectedRange = Intersect(Target, Sh.Columns("B"))
        
        If affectedRange Is Nothing Then
        Exit Sub
        End If
                
        Application.EnableEvents = False
        Dim cell As Range
        For Each cell In affectedRange
           If Trim(cell.Value) <> "" Then
              ' B列非空：K列和L列赋值为"无"
              Sh.Cells(cell.Row, "K").Value = "无"
              Sh.Cells(cell.Row, "L").Value = "无"
              Sh.Cells(cell.Row, "A").Font.Color = RGB(0, 0, 0)
              Sh.Cells(cell.Row, "A").Interior.Color = xlNone
            Else
              ' B列为空：清除K列和L列内容if
                Sh.Cells(cell.Row, "K").ClearContents
                Sh.Cells(cell.Row, "L").ClearContents
                Sh.Cells(cell.Row, "G").ClearContents
                Sh.Cells(cell.Row, "M").ClearContents
                Sh.Cells(cell.Row, "A").Font.Color = RGB(255, 255, 255)
                Sh.Cells(cell.Row, "A").Interior.Color = RGB(218, 165, 32)
              
           End If
        Next cell
        
        Application.EnableEvents = True
    End If
End Sub

Private Sub Workbook_Open()

  InitOrdersFormat
  
    
End Sub

Private Function GetCurrentWorksheetName() As String
  Dim currentDate As Date
  
  currentDate = GetCurrentDate()
  GetCurrentWorksheetName = Format(currentDate, "m月d日")
End Function

Private Function GetCurrentDate() As Date

If Hour(Now) >= 20 Then
   GetCurrentDate = DateAdd("d", 1, Date)
Else
  GetCurrentDate = Date
End If
  
End Function

Private Function GetCurrentOrders() As Variant
Dim mondayStr As String
Dim tuesdayStr As String
Dim wednesdayStr As String
Dim thursdayStr As String
Dim fridayStr As String
Dim saturdayStr As String
Dim sundayStr As String
Dim weekdayNum As Integer
Dim orders As Variant
Dim sheetName As String

mondayStr = "参考消息,长江商报,都市报省版,都市报市版,法治日报,工人日报,光明日报,国家电网,湖北日报,检察日报,健康报,金融时报,经济参考,经济日报,科技日报,农民日报,人民法院,人民铁道,仙桃日报,新华电讯,中国妇女,中国青年,中国日报,中国社会,中国石化,中国证券"

tuesdayStr = "湖北日报,光明日报,农民日报,健康报,金融时报,人民铁道,中国石化,人民法院,国家电网,科技日报,中国证券,参考消息,工人日报,法治日报,中国青年,仙桃日报,武汉铁道,人民武警,都市报省版,中国社会,文摘周报,中国妇女,中国日报,检察日报,长江商报,经济参考,经济日报,都市报市版,水利报,新华电讯"

wednesdayStr = "湖北日报,都市报市版,农村新报,工作日报,新华电讯,健康报,金融时报,科技日报,国家电网报,中国证券,参考消息,法治日报,经济参考,农民日报,人民铁道,仙桃日报,新洲报,人民武警,都市报省版,中国石化,水利报,中国妇女,中国日报,长江商报,中国社会,检察日报,中国青年,经济日报,快乐老人,人民法院,亮报,光明日报"

thursdayStr = "湖北日报,法治日报,工人日报,光明日报,健康报,金融时报,中国石化,中国证券,水利报,科技日报,参考消息,农民日报,中国青年,经济参考,新华电讯,中国社会,人民武警,仙桃日报,都市报省版,文摘周报,人民法院,中国妇女,中国日报,长江商报,检察日报,都市报市版,南方周末,经济日报,人民铁道,国家电网"

fridayStr = "参考消息,长江商报,都市报省版,都市报市版,水利报,健康报,人民铁道,人民武警,法治日报,工人日报,光明日报,国家电网,湖北日报,检察日报,金融时报,经济参考,经济日报,科技日报,农民日报,人民法院,武汉铁道,仙桃日报,新华电讯,中国妇女,中国青年,中国日报,中国社会,中国石化,中国证券"

saturdayStr = "湖北日报,农村新报,中国证券,新华电讯,检察日报,参考消息,法治日报,中国青年,都市报省版,水利报,中国妇女,人民武警,人民法院,中国日报（1-12）,书法报,工人日报,经济日报,快乐老人,都市报市版,光明日报,农民日报,人民铁道"

sundayStr = "湖北日报,参考消息,新华电讯,法治日报,工人日报,中国青年,中国妇女,检察日报,人民法院,人民铁道,经济日报,都市报市版,光明日报"

sheetName = GetCurrentWorksheetName()

Select Case sheetName
  Case "5月1日": GetCurrentOrders = Split("湖北日报,都市报市版,参考消息,中国青年,经济日报,新华电讯,光明日报,中国日报（1-12）", ",")
                 Exit Function
  Case "5月2日": GetCurrentOrders = Split("湖北日报,都市报市版,参考消息,中国青年,经济日报,新华电讯,光明日报,中国日报（1-12）,农民日报", ",")
                 Exit Function
  Case "5月3日": GetCurrentOrders = Split("湖北日报,都市报市版,参考消息,中国青年,经济日报,新华电讯,光明日报,中国日报（1-12）,农民日报", ",")
                 Exit Function
  Case "5月4日": GetCurrentOrders = Split("湖北日报,都市报市版,参考消息,中国青年,经济日报,新华电讯,光明日报,中国日报（1-12）", ",")
                 Exit Function
End Select

weekdayNum = Weekday(GetCurrentDate, vbSunday)

Select Case weekdayNum
  Case 1: orders = Split(sundayStr, ",")
  Case 2: orders = Split(mondayStr, ",")
  Case 3: orders = Split(tuesdayStr, ",")
  Case 4: orders = Split(wednesdayStr, ",")
  Case 5: orders = Split(thursdayStr, ",")
  Case 6: orders = Split(fridayStr, ",")
  Case 7: orders = Split(saturdayStr, ",")
  Case Else: Exit Function
End Select

GetCurrentOrders = orders
End Function

Private Sub InitOrdersFormat()
Dim orders As Variant
Dim cell As Range
Dim aRng As Range
Dim ws As Worksheet
Dim order As Variant
Dim worksheetName As String
Dim shouldHighlight As Boolean

worksheetName = GetCurrentWorksheetName()

Set ws = Worksheets(worksheetName)
orders = GetCurrentOrders()

If ws Is Nothing Then Exit Sub
If ws.ProtectContents Then Exit Sub
If Not IsArray(orders) Then Exit Sub

Set aRng = ws.Range("a2:a52")
Application.ScreenUpdating = False
Application.EnableEvents = False
ws.Activate

For Each cell In aRng
   shouldHighlight = False
   
   If Len(Trim(cell.Value)) > 0 Then
      For Each order In orders
       If InStr(1, cell.Value, order, vbTextCompare) > 0 Then
          If IsEmpty(cell.Offset(0, 1)) Then
             shouldHighlight = True
          End If
          Exit For
       End If
   Next order
   End If
   
   If shouldHighlight Then
      cell.Font.Color = RGB(255, 255, 255)
      cell.Interior.Color = RGB(218, 165, 32)
   Else
      cell.Font.Color = RGB(0, 0, 0)
      cell.Interior.Color = xlNone
   End If
   
Next cell
Application.ScreenUpdating = True
Application.EnableEvents = True


End Sub

在千问的帮助下完成，AI写单个方法或函数是没有问题的。