如何实现一单元格填写，触发相应的5个新的结果填写变量

hongyunhada

求助大侠老师，工作簿实现操作目标：
        相当于Sheet2”学校就餐信息”E列出现的日期是一个自动触发按钮（原因变量），自动填入就出现下面填写的信息，删除就删除填入的信息（5个随应结果变量）。逻辑思路要示如下：


        如果Sheet2”学校就餐信息”E列下面空白行单元格出现一个日期，则在Sheet4“用餐订单信息”D列空白行出现sheet19”学生名单”其中一段学生名单（结果变量1）。


       Sheet4“用餐订单信息”D列空白行出现sheet19”学生名单选择要求：7月5日前为sheet19A列A2开始的名单；8月31日后为sheet19A列C1后的名单。


        姓名后面F列对应填入Sheet2的E列某行单元格出现的日期（结果变量2）。其它对应行，复制填入上面相同的信息（结果变量3）。


        Sheet2”学校就餐信息”E列空白行单元格一旦出现日期，则，F列对应行填入Sheet4的D列的名单人数数量（结果变量4），对应其它行复制填入上一行信息（结果变量5）。

hongyunhada

     这道题目的难点是：1.引发程序的条件变量单元格是不固定，触发条件为Sheet3 E列空格变非空格并且要判断是7月5日之前，还是8月31日之后（怎么判断日期？），再来分别作出结果反应变量。2.结果反应变量又得批量填写到空行对应单元格且填写要求不同。
      “攻城不怕坚，攻书莫畏难。科学有险阻，只发肯登攀！”（叶剑英）借用军事思维，化繁为简，分兵各个击破，积小胜为大胜。思路如下：
       是否可以分解成这样6个宏程序，最后一键启动执行这六个程序？

      程序1：设定Sheet4的M1为条件单元格，此单元格用来读取存储Sheet2的E列最下行非空值单元格日期。如果与上行日期值相同，则存储为空值。

      程序2：判断条件Sheet4的M1单元格，如果出现日期，并且为小于7月5日前，则反应变量为复制sheet19 的 A2:A1048576非空段数值，拷贝到Sheet4的D列最下方行空单元格中。否则其它日期，则复制sheet19 的 C2:C1048576非空段数值，拷贝到Sheet4的D列最下方行空单元格中。

     程序3：令Sheet4的对应F列最下方行空单元格等于Sheet4的M1单元格的值。

     程序4：令Sheet2的A、B、C、D列最下方行空单元格复制上一行信息。

     程序5：令Sheet2的F列最下方行空单元格读取——对应E列同行日期的人数——来源：Sheet4的F列日期=Sheet2的E列最下行单元格值对应的D列非空值数量）

    程序6：令Sheet4的列A、B、C、E、G、H、I最下行空单元格复制上一行数值。

    总执行宏程序7：
    程序1：
    程序2：
    程序3：
    程序4：
    程序5：
    程序6：
     请高手老师帮助不会写代码的老人，编写这6个小程序？

Doris丶煉獄Hà

这些记录只添加不修改,所以H列建议去掉.
记录删除后就没有了,所以I列也没用
同理”用餐订单信息”中的K,L列也没用.
删除单元格的日期后不能取到它的值,所以
原本删除思路不可取,改为选 中行中的任意
非空单元格,然后点紫色”删除记录”按钮来删除
对应行及其日期的”用餐订单信息”

表”配置”中可设置一些常量:
其中”上学期时间”和”下学期时间”需要按该校实际情况设置好(用于判断取学生名单)

hongyunhada

将任务分成4个程序，1个事件来实验自动操作，代码如下：
Sub ⑴单元格M1存日期()
Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lastRow As Long
    Dim hasDuplicates As Boolean
    Dim rng As Range
    Dim cell As Range

    ' 设置工作表
    Set ws1 = ThisWorkbook.Worksheets("用餐订单信息")
    Set ws2 = ThisWorkbook.Worksheets("学校就餐信息")

    ' 检查sheet2列E中是否有重复数据
    lastRow = ws2.Cells(ws2.Rows.Count, "E").End(xlUp).Row
    Set rng = ws2.Range("E1:E" & lastRow)
    hasDuplicates = Application.WorksheetFunction.CountIf(rng, ">0") > rng.Cells.Count

    ' 根据是否有重复数据设置M1单元格的值
    If hasDuplicates Then
        ws1.Range("M1").ClearContents
    Else
        ws1.Range("M1").Value = ws2.Range("E" & lastRow).Value
    End If
End Sub

Sub ⑵根据日期选择拷贝名单()
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lastRowSource As Long
    Dim lastRowDest As Long
    Dim copyRange As Range
    Dim sourceColumn As String
   
    ' 设置工作表
    Set ws1 = ThisWorkbook.Sheets("学生名单")
    Set ws2 = ThisWorkbook.Sheets("用餐订单信息")
   
    ' 检查表2的M1单元格是否为空
    If IsEmpty(ws2.Range("M1").Value) Then
        MsgBox "表2的M1单元格为空，宏程序将退出。", vbExclamation
        Exit Sub
    End If
   
    ' 检查表2的M1单元格日期是否超过当年8月30日
    If CDate(ws2.Range("M1").Value) > DateSerial(Year(Date), 8, 30) Then
        ' 超过8月30日，复制表19列C行2及以下非空数据
        sourceColumn = "C"
    Else
        ' 未超过8月30日，复制表1列A行2及以下非空数据
        sourceColumn = "A"
    End If
   
    ' 找到表19源列的最后一行
    lastRowSource = ws1.Cells(ws1.Rows.Count, sourceColumn).End(xlUp).Row
   
    ' 找到表2目标列D的最后一行
    lastRowDest = ws2.Cells(ws2.Rows.Count, "D").End(xlUp).Row
   
    ' 确定复制数据的范围（行2及以下非空单元格）
    Set copyRange = ws1.Range(sourceColumn & "2:" & sourceColumn & lastRowSource).SpecialCells(xlCellTypeConstants)
   
    ' 确定目标起始行（D列下方空行）
    Dim destRow As Long
    destRow = lastRowDest + 1
   
    ' 复制数据到表2的D列下方空行
    copyRange.Copy Destination:=ws2.Range("D" & destRow)
   
    ' 清理
    Set ws1 = Nothing
    Set ws2 = Nothing
    Set copyRange = Nothing
End Sub

Sub ⑶填满其它相关空格()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim m1Date As Date
    Dim fillValue As Variant
    Dim colsToFill As Variant
   
    ' 设置工作表4
    Set ws = ThisWorkbook.Sheets("用餐订单信息")
   
    ' 获取M1单元格的日期值
    m1Date = ws.Range("M1").Value
   
    ' 确保M1单元格包含有效的日期
    If IsEmpty(m1Date) Or Not IsDate(m1Date) Then
        MsgBox "M1单元格为空或不是有效的日期，宏程序将退出。", vbExclamation
        Exit Sub
    End If
   
    ' 定义需要填充的列
    colsToFill = Array("A", "B", "C", "E", "G", "H", "I")
   
    ' 找到D列的最后一行
    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
   
    ' 遍历D列的每一行
    For i = 1 To lastRow
        ' 检查D列当前行是否为非空，且F列对应行为空
        If Not IsEmpty(ws.Cells(i, "D").Value) And IsEmpty(ws.Cells(i, "F").Value) Then
            ' 将F列对应行设置为M1单元格的日期值
            ws.Cells(i, "F").Value = m1Date
            
            ' 遍历需要填充的列
            For Each col In colsToFill
                ' 检查当前列当前行是否为空
                If IsEmpty(ws.Cells(i, col).Value) Then
                    ' 查找当前列最尾部的非空单元格值
                    fillValue = ws.Cells(ws.Rows.Count, col).End(xlUp).Value
                    ' 将找到的值填充到当前列当前行
                    ws.Cells(i, col).Value = fillValue
                End If
            Next col
        End If
    Next i
   
    ' 清理
    Set ws = Nothing
End Sub

Sub ⑷填写统计()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastRow2 As Long, countAsSame As Long
    Dim eValue As Variant, fillValue As Variant
    Dim i As Long, j As Long
    Dim colsToFill As Variant
   
    ' 设置工作表
    Set ws1 = ThisWorkbook.Sheets("用餐订单信息")
    Set ws2 = ThisWorkbook.Sheets("学校就餐信息")
   
    ' 定义需要填充的列
    colsToFill = Array("A", "B", "C", "D")
   
    ' 找到表2的E列的最后一行
    lastRow2 = ws2.Cells(ws2.Rows.Count, "E").End(xlUp).Row
   
    ' 获取表2的E列最后一行的值
    eValue = ws2.Cells(lastRow2, "E").Value
   
    ' 检查E列最后一行是否为非空，且F列对应行为空
    If Not IsEmpty(eValue) And IsEmpty(ws2.Cells(lastRow2, "F").Value) Then
        ' 统计表4的F列中与表2的E列最后一行相同值的总个数
        countAsSame = Application.WorksheetFunction.CountIf(ws1.Columns("F"), eValue)
        
        ' 将统计结果填入表2的F列对应行
        ws2.Cells(lastRow2, "F").Value = countAsSame
        
        ' 遍历需要填充的列
        For Each col In colsToFill
            ' 检查表2当前列当前行是否为空
            If IsEmpty(ws2.Cells(lastRow2, col).Value) Then
                ' 查找表2当前列最尾部的非空单元格值
                fillValue = ws2.Cells(ws2.Rows.Count, col).End(xlUp).Value
                ' 将找到的值填充到表2当前列当前行
                ws2.Cells(lastRow2, col).Value = fillValue
            End If
        Next col
    End If
   
    ' 清理
    Set ws1 = Nothing
    Set ws2 = Nothing
End Sub

在工作表“学校就餐信息”Sheet4写入激发事件代码：
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lastRow As Long
    Dim checkRange As Range
    Dim cell As Range
    Dim isDuplicate As Boolean
    Dim ws As Worksheet
   
    ' 设置工作表
    Set ws = ThisWorkbook.Sheets("学校就餐信息")
   
    ' 检查变化是否发生在E列
    If Not Intersect(Target, ws.Columns("E")) Is Nothing Then
        ' 找到E列的最后一个非空单元格
        lastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
        
        ' 检查是否是E列的最后一行被填写
        If Target.Row = lastRow Then
            ' 设置要检查的范围（E列从第1行到倒数第2行）
            Set checkRange = ws.Range("E1:E" & lastRow - 1)
            
            ' 初始化重复标志
            isDuplicate = False
            
            ' 检查新输入的数据是否与E列中的其他数据重复
            For Each cell In checkRange
                If cell.Value = Target.Value Then
                    isDuplicate = True
                    Exit For
                End If
            Next cell
            
            ' 如果没有重复，则依次执行宏程序
            If Not isDuplicate Then
            Call ⑴单元格M1存日期
            Call ⑵根据日期选择拷贝名单
            Call ⑶填满其它相关空格
            Call ⑷填写统计
            Else
                ' 如果有重复，则停止执行并退出
                MsgBox "E列中存在重复数据，停止执行宏程序。"
                Exit Sub
            End If
        End If
    End If
End Sub