VBA宏功能扩展需求：新增tbl_Termine日期匹配校验逻辑

以下是修改后的完整代码，在原有校验逻辑基础上新增了日期存在性判断：

Sub ErgebnisEintragen()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim targetDate As Date
    Dim dateExists As Boolean
    Dim conn As Object
    Dim rs As Object
    Dim sql As String
    
    ' 指定要操作的工作表，按需修改表名
    Set ws = ThisWorkbook.Worksheets("Tabelle1")
    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row ' 以第4列(D列)确定数据最后一行
    
    ' 建立ADO连接到当前工作簿（若tbl_Termine在Access数据库中，需替换连接字符串）
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Macro;HDR=YES"";"
    
    ' 从第2行开始遍历数据（假设第1行是表头）
    For i = 2 To lastRow
        dateExists = False
        
        ' 原校验逻辑：第4列=0 且 第5列>0
        If ws.Cells(i, "D").Value = 0 And ws.Cells(i, "E").Value > 0 Then
            targetDate = ws.Cells(i, "F").Value ' 获取第6列(F列)的日期
            
            ' 构造SQL查询，检查日期是否存在于tbl_Termine表中
            sql = "SELECT COUNT(*) FROM tbl_Termine WHERE Datum = #" & Format(targetDate, "yyyy-mm-dd") & "#"
            Set rs = conn.Execute(sql)
            
            ' 若查询结果大于0，说明日期存在
            If rs.Fields(0).Value > 0 Then
                dateExists = True
            End If
            
            ' 根据检查结果写入对应文本到第7列(G列)
            ws.Cells(i, "G").Value = IIf(dateExists, "bei Termin entfernt", "entfernt")
        Else
            ' 不满足条件时清空第7列（可根据需求删除此行）
            ws.Cells(i, "G").Value = ""
        End If
    Next i
    
    ' 释放资源
    rs.Close
    conn.Close
    Set rs = Nothing
    Set conn = Nothing
    Set ws = Nothing
End Sub

关键适配说明： #

• 连接字符串调整：如果tbl_Termine是Access数据库中的表，替换连接字符串为：

  conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\DeinPfad\Datenbank.accdb;"
  

• 字段名适配：确保tbl_Termine中存储日期的字段名为Datum，若字段名不同需修改SQL语句中的对应名称
• 日期格式兼容：用yyyy-mm-dd格式拼接SQL，避免因系统区域设置导致的日期解析错误
• 表头行适配：代码默认第1行是表头，若数据从第1行开始，需把For i = 2 To lastRow改为For i = 1 To lastRow

内容的提问来源于stack exchange，提问作者Örv