├── .DS_Store ├── utils ├── GetMergedLastRow.vba ├── SetDailyWeeklyMonthlyDate.vba ├── AddSummary.vba ├── AddMonthlyDataIfInCurrentMonth.vba ├── CheckToday.vba └── CheckThenSetDateAndCopy.vba ├── README.md ├── offsite ├── 1.step.txt ├── 1.step.vba ├── 2.step.txt └── 2.step.vba └── small ├── 1.step.vba └── 2.step.vba /.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/chiupam/PICC/main/.DS_Store -------------------------------------------------------------------------------- /utils/GetMergedLastRow.vba: -------------------------------------------------------------------------------- 1 | Sub GetMergedLastRow() 2 | Dim rng As Range 3 | Dim lastRow As Long 4 | 5 | Set rng = ThisWorkbook.Sheets("日监控表").Range("A4") 6 | 7 | If rng.MergeCells Then 8 | lastRow = rng.MergeArea.Row + rng.MergeArea.Rows.Count - 1 9 | MsgBox "合并区域最后一行的行号是：" & lastRow 10 | Else 11 | MsgBox "A4 没有合并单元格" 12 | End If 13 | End Sub -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # PICC 理赔数据自动化处理系统 2 | 3 | 用于自动化处理 PICC 理赔部门的日常数据报表工作 4 | 5 | ## 项目说明 6 | 7 | 本项目用于自动化处理 PICC 理赔部门的每日数据报表，主要功能包括： 8 | 9 | ### 主要功能 10 | - 自动处理每日数据更新 11 | - 自动处理每周数据汇总 12 | - 自动处理每月数据统计 13 | - 自动计算各项指标和比率 14 | 15 | ### 使用说明 16 | 1. 打开 Excel 文件 17 | 2. 运行 `StepOne` 宏进行数据初始化 18 | 3. 填写当日数据 19 | 4. 运行 `StepTwo` 宏进行数据汇总和计算 20 | 21 | ### 注意事项 22 | - 使用前请确保 Excel 已启用宏 23 | - 请按照正确的顺序执行宏 24 | - 数据填写完成后请及时保存 25 | 26 | ### 文件结构 27 | - `offsite/1.step.vba`: 第一步数据处理 28 | - `offsite/2.step.vba`: 第二步数据汇总 29 | - `utils/`: 工具函数 30 | - `GetMergedLastRow.vba`: 获取合并单元格最后一行 31 | - `AddMonthlyDataIfInCurrentMonth.vba`: 月度数据处理 32 | 33 | ### 开发说明 34 | 本项目使用 VBA 开发，主要处理 Excel 数据报表的自动化操作。 35 | -------------------------------------------------------------------------------- /utils/SetDailyWeeklyMonthlyDate.vba: -------------------------------------------------------------------------------- 1 | Sub SetDailyWeeklyMonthlyDate_NoYear() ' 定义一个过程，名为 SetDailyWeeklyMonthlyDate_NoYear 2 | Dim today As Date ' 定义变量 today，用于存储今天的日期 3 | Dim startOfWeek As Date ' 定义变量 startOfWeek，用于存储本周的周一日期 4 | Dim endOfWeek As Date ' 定义变量 endOfWeek，用于存储本周的周日日期 5 | Dim dailyText As String ' 定义变量 dailyText，用于存储“每日”显示的文字 6 | Dim weeklyText As String ' 定义变量 weeklyText，用于存储“每周”显示的文字 7 | Dim monthlyText As String ' 定义变量 monthlyText，用于存储“每月”显示的文字 8 | 9 | today = Date ' 获取当前系统日期，赋值给 today 10 | 11 | dailyText = "每日（" & Month(today) & "." & Day(today) & "）" ' 构建每日文字，例如“每日（5.24）” 12 | Range("C2").Value = dailyText ' 将 dailyText 写入 Excel 的 C2 单元格 13 | 14 | startOfWeek = today - Weekday(today, vbMonday) + 1 ' 计算本周周一的日期 15 | endOfWeek = startOfWeek + 6 ' 计算本周周日的日期（周一 + 6 天） 16 | 17 | weeklyText = "每周（" & Month(startOfWeek) & "." & Day(startOfWeek) & "-" & Month(endOfWeek) & "." & Day(endOfWeek) & "）" 18 | ' 构建每周文字，例如“每周（5.20-5.26）” 19 | Range("K2").Value = weeklyText ' 将 weeklyText 写入 Excel 的 K2 单元格 20 | 21 | monthlyText = "每月（" & Month(today) & "月）" ' 构建每月文字，例如“每月（5月）” 22 | Range("R2").Value = monthlyText ' 将 monthlyText 写入 Excel 的 R2 单元格 23 | End Sub ' 宏结束 -------------------------------------------------------------------------------- /utils/AddSummary.vba: -------------------------------------------------------------------------------- 1 | Sub AddSummary() 2 | Dim lastRow As Long 3 | Dim todayCount As Long 4 | Dim monthCount As Long 5 | Dim i As Long 6 | Dim dateColumn As Integer 7 | Dim cellDate As Date 8 | Dim summaryRow As Long 9 | Dim outputColToday As Integer 10 | Dim outputColMonth As Integer 11 | 12 | dateColumn = 7 ' G列：调解日期 13 | outputColToday = 9 ' I列 14 | outputColMonth = 10 ' J列 15 | 16 | ' 找到数据最后一行 17 | lastRow = Cells(Rows.Count, dateColumn).End(xlUp).Row 18 | 19 | ' 清空 I列 和 J列 的内容与边框 20 | Range(Cells(1, outputColToday), Cells(lastRow + 1, outputColMonth)).Clear 21 | 22 | ' 统计当天和本月数量 23 | For i = 1 To lastRow 24 | If IsDate(Cells(i, dateColumn).Value) Then 25 | cellDate = CDate(Cells(i, dateColumn).Value) 26 | If DateValue(cellDate) = DateValue(Date) Then 27 | todayCount = todayCount + 1 28 | End If 29 | If Month(cellDate) = Month(Date) And Year(cellDate) = Year(Date) Then 30 | monthCount = monthCount + 1 31 | End If 32 | End If 33 | Next i 34 | 35 | ' 输出结果到 I列 和 J列 的最后一行+1 36 | summaryRow = lastRow + 1 37 | Cells(summaryRow, outputColToday).Value = todayCount 38 | Cells(summaryRow, outputColMonth).Value = monthCount 39 | 40 | ' 设置边框 41 | With Range(Cells(summaryRow, outputColToday), Cells(summaryRow, outputColMonth)).Borders 42 | .LineStyle = xlContinuous 43 | .Weight = xlThin 44 | .ColorIndex = xlAutomatic 45 | End With 46 | End Sub -------------------------------------------------------------------------------- /utils/AddMonthlyDataIfInCurrentMonth.vba: -------------------------------------------------------------------------------- 1 | Sub AddMonthlyDataIfInCurrentMonth() 2 | Dim today As Date 3 | today = Date 4 | 5 | ' 从 R2 提取当前显示的月份 6 | Dim monthText As String 7 | monthText = Range("R2").Value 8 | 9 | ' 提取月份数字 10 | Dim targetMonth As Integer 11 | Dim startPos As Long, endPos As Long 12 | startPos = InStr(monthText, "（") + 1 13 | endPos = InStr(monthText, "月") 14 | 15 | If startPos > 0 And endPos > startPos Then 16 | targetMonth = CInt(Mid(monthText, startPos, endPos - startPos)) 17 | Else 18 | MsgBox "R2 的格式不正确，无法识别月份", vbExclamation 19 | Exit Sub 20 | End If 21 | 22 | ' 判断当前月份是否匹配 23 | If Month(today) = targetMonth Then 24 | Dim row As Long 25 | row = 4 26 | 27 | Do While Not IsEmpty(Cells(row, "C")) 28 | ' C, D, E, G, H → R, S, T, U, V 29 | Dim srcCols As Variant, destCols As Variant 30 | srcCols = Array(3, 4, 5, 7, 8) ' C, D, E, G, H 31 | destCols = Array(18, 19, 20, 21, 22) ' R, S, T, U, V 32 | 33 | Dim i As Long 34 | For i = 0 To UBound(srcCols) 35 | Dim val1 As Variant, val2 As Variant 36 | val1 = Cells(row, srcCols(i)).Value 37 | val2 = Cells(row, destCols(i)).Value 38 | 39 | If IsNumeric(val1) And IsNumeric(val2) Then 40 | Cells(row, destCols(i)).Value = CDbl(val1) + CDbl(val2) 41 | End If 42 | Next i 43 | 44 | row = row + 1 45 | Loop 46 | End If 47 | End Sub -------------------------------------------------------------------------------- /utils/CheckToday.vba: -------------------------------------------------------------------------------- 1 | Sub SetAndCheckDateDisplay() 2 | Dim today As Date 3 | Dim startOfWeek As Date 4 | Dim endOfWeek As Date 5 | Dim dailyText As String 6 | Dim weeklyText As String 7 | Dim monthlyText As String 8 | 9 | today = Date 10 | 11 | ' 设置 C2：每日（M.D） 12 | dailyText = "每日（" & Month(today) & "." & Day(today) & "）" 13 | Range("C2").Value = dailyText 14 | 15 | ' 设置 K2：每周（M.D-M.D） 16 | startOfWeek = today - Weekday(today, vbMonday) + 1 17 | endOfWeek = startOfWeek + 6 18 | weeklyText = "每周（" & Month(startOfWeek) & "." & Day(startOfWeek) & "-" & Month(endOfWeek) & "." & Day(endOfWeek) & "）" 19 | Range("K2").Value = weeklyText 20 | 21 | ' 设置 R2：每月（M月） 22 | monthlyText = "每月（" & Month(today) & "月）" 23 | Range("R2").Value = monthlyText 24 | 25 | ' 判断：是否是 C2 当日 26 | If Range("C2").Value = dailyText Then 27 | MsgBox "今天是 C2 显示的日期（每日）" 28 | Else 29 | MsgBox "今天不是 C2 显示的日期（每日）" 30 | End If 31 | 32 | ' 判断：是否是 K2 这周 33 | Dim weeklyTextToday As String 34 | weeklyTextToday = "每周（" & Month(startOfWeek) & "." & Day(startOfWeek) & "-" & Month(endOfWeek) & "." & Day(endOfWeek) & "）" 35 | 36 | If Range("K2").Value = weeklyTextToday Then 37 | MsgBox "今天属于 K2 显示的周范围" 38 | Else 39 | MsgBox "今天不在 K2 显示的周范围" 40 | End If 41 | 42 | ' 判断：是否是 R2 这个月 43 | Dim thisMonthText As String 44 | thisMonthText = "每月（" & Month(today) & "月）" 45 | 46 | If Range("R2").Value = thisMonthText Then 47 | MsgBox "今天是 R2 显示的月份" 48 | Else 49 | MsgBox "今天不是 R2 显示的月份" 50 | End If 51 | End Sub -------------------------------------------------------------------------------- /utils/CheckThenSetDateAndCopy.vba: -------------------------------------------------------------------------------- 1 | Sub CheckThenSetDateAndCopy() 2 | Dim today As Date 3 | today = Date 4 | 5 | ' ========== 1. 判断 & 复制 ========== 6 | 7 | ' 1.1 判断每日（C2）是否今天，若不是则复制 G → I 8 | Dim expectedDailyText As String 9 | expectedDailyText = "每日（" & Month(today) & "." & Day(today) & "）" 10 | 11 | If Range("C2").Value <> expectedDailyText Then 12 | Dim i As Long 13 | i = 4 14 | Do While Not IsEmpty(Cells(i, "G")) 15 | Cells(i, "I").Value = Cells(i, "G").Value 16 | i = i + 1 17 | Loop 18 | End If 19 | 20 | ' 1.2 判断每周（K2）是否包含今天，若不包含则复制 N → P 21 | Dim startOfWeek As Date, endOfWeek As Date 22 | startOfWeek = today - Weekday(today, vbMonday) + 1 23 | endOfWeek = startOfWeek + 6 24 | Dim expectedWeeklyText As String 25 | expectedWeeklyText = "每周（" & Month(startOfWeek) & "." & Day(startOfWeek) & "-" & Month(endOfWeek) & "." & Day(endOfWeek) & "）" 26 | 27 | If Range("K2").Value <> expectedWeeklyText Then 28 | Dim j As Long 29 | j = 4 30 | Do While Not IsEmpty(Cells(j, "N")) 31 | Cells(j, "P").Value = Cells(j, "N").Value 32 | j = j + 1 33 | Loop 34 | End If 35 | 36 | ' 1.3 判断每月（R2）是否本月，若不是则复制 U → W 37 | Dim expectedMonthlyText As String 38 | expectedMonthlyText = "每月（" & Month(today) & "月）" 39 | 40 | If Range("R2").Value <> expectedMonthlyText Then 41 | Dim k As Long 42 | k = 4 43 | Do While Not IsEmpty(Cells(k, "U")) 44 | Cells(k, "W").Value = Cells(k, "U").Value 45 | k = k + 1 46 | Loop 47 | End If 48 | 49 | ' ========== 2. 设置日期（C2/K2/R2）为今天 ========== 50 | 51 | Range("C2").Value = expectedDailyText 52 | Range("K2").Value = expectedWeeklyText 53 | Range("R2").Value = expectedMonthlyText 54 | End Sub -------------------------------------------------------------------------------- /offsite/1.step.txt: -------------------------------------------------------------------------------- 1 | Sub StepOne() 2 | Dim ws As Worksheet 3 | Set ws = ThisWorkbook.Sheets("日监控表") 4 | 5 | Dim today As Date: today = Date 6 | Dim row As Long 7 | 8 | ' ==== 判断是否正在填写数据 ==== 9 | If InStr(ws.Range("C2").Value, "正在填写数据") > 0 Then 10 | MsgBox "请填写当天数据" 11 | Exit Sub 12 | End If 13 | 14 | ' ==== 判断是否已更新今日每日数据 ==== 15 | Dim currentDailyHeader As String 16 | currentDailyHeader = "每日（" & Month(today) & "." & Day(today) & "）" 17 | 18 | If ws.Range("C2").Value = currentDailyHeader Then 19 | MsgBox "当天日期数据已更新！" 20 | Exit Sub 21 | End If 22 | 23 | ' ==== 处理每日（C2） ==== 24 | Dim dailyText As String: dailyText = ws.Range("C2").Value 25 | Dim isTodayDaily As Boolean 26 | isTodayDaily = (InStr(dailyText, currentDailyHeader) > 0) 27 | 28 | If Not isTodayDaily Then 29 | row = 4 30 | Do While Not IsEmpty(ws.Cells(row, "C")) 31 | ' 复制 G → I 32 | ws.Cells(row, "I").Value = ws.Cells(row, "G").Value 33 | 34 | ' 清空 C, D, E, G, H 35 | ws.Cells(row, "C").ClearContents 36 | ws.Cells(row, "D").ClearContents 37 | ws.Cells(row, "E").ClearContents 38 | ws.Cells(row, "G").ClearContents 39 | ws.Cells(row, "H").ClearContents 40 | 41 | row = row + 1 42 | Loop 43 | End If 44 | 45 | ' ==== 处理每周（K2） ==== 46 | Dim weeklyText As String: weeklyText = ws.Range("K2").Value 47 | Dim startText As String, endText As String 48 | Dim startDate As Date, endDate As Date 49 | Dim thisMonday As Date, thisSunday As Date 50 | Dim y As Integer 51 | 52 | If InStr(weeklyText, "每周（") > 0 Then 53 | startText = Mid(weeklyText, InStr(weeklyText, "（") + 1, InStr(weeklyText, "-") - InStr(weeklyText, "（") - 1) 54 | endText = Mid(weeklyText, InStr(weeklyText, "-") + 1, InStr(weeklyText, "）") - InStr(weeklyText, "-") - 1) 55 | 56 | y = Year(today) 57 | startDate = DateSerial(y, CInt(Split(startText, ".")(0)), CInt(Split(startText, ".")(1))) 58 | endDate = DateSerial(y, CInt(Split(endText, ".")(0)), CInt(Split(endText, ".")(1))) 59 | 60 | thisMonday = today - Weekday(today, vbMonday) + 1 61 | thisSunday = thisMonday + 6 62 | 63 | If Not (today >= startDate And today <= endDate) Then 64 | row = 4 65 | Do While Not IsEmpty(ws.Cells(row, "K")) 66 | ' 复制 O → P 67 | ws.Cells(row, "P").Value = ws.Cells(row, "O").Value 68 | ' 清空 K:L:M:N:O 69 | ws.Range(ws.Cells(row, "K"), ws.Cells(row, "O")).ClearContents 70 | row = row + 1 71 | Loop 72 | End If 73 | End If 74 | 75 | ' ==== 处理每月（R2） ==== 76 | Dim monthlyText As String: monthlyText = ws.Range("R2").Value 77 | Dim monthNum As Integer 78 | Dim todayMonthStart As Date, todayMonthEnd As Date 79 | 80 | If InStr(monthlyText, "每月（") > 0 Then 81 | monthNum = CInt(Replace(Replace(monthlyText, "每月（", ""), "月）", "")) 82 | todayMonthStart = DateSerial(Year(today), monthNum, 1) 83 | todayMonthEnd = DateSerial(Year(today), monthNum + 1, 0) 84 | 85 | If Not (today >= todayMonthStart And today <= todayMonthEnd) Then 86 | row = 4 87 | Do While Not IsEmpty(ws.Cells(row, "R")) 88 | ' 复制 V → W 89 | ws.Cells(row, "W").Value = ws.Cells(row, "V").Value 90 | ' 清空 R:S:T:U:V 91 | ws.Range(ws.Cells(row, "R"), ws.Cells(row, "V")).ClearContents 92 | row = row + 1 93 | Loop 94 | End If 95 | End If 96 | 97 | ' ==== 执行结束后，在 C2 加“(正在填写数据)” ==== 98 | ws.Range("C2").Value = currentDailyHeader & "(正在填写数据)" 99 | End Sub -------------------------------------------------------------------------------- /offsite/1.step.vba: -------------------------------------------------------------------------------- 1 | Sub StepOne() 2 | Dim ws As Worksheet 3 | Set ws = ThisWorkbook.Sheets("日监控表") 4 | 5 | Dim today As Date: today = Date 6 | Dim row As Long 7 | 8 | ' ==== 判断是否正在填写数据 ==== 9 | If InStr(ws.Range("C2").Value, "正在填写数据") > 0 Then 10 | MsgBox "请填写当天数据" 11 | Exit Sub 12 | End If 13 | 14 | ' ==== 判断是否已更新今日每日数据 ==== 15 | Dim currentDailyHeader As String 16 | currentDailyHeader = "每日（" & Month(today) & "." & Day(today) & "）" 17 | 18 | If ws.Range("C2").Value = currentDailyHeader Then 19 | MsgBox "当天日期数据已更新！" 20 | Exit Sub 21 | End If 22 | 23 | ' ==== 处理每日（C2） ==== 24 | Dim dailyText As String: dailyText = ws.Range("C2").Value 25 | Dim isTodayDaily As Boolean 26 | isTodayDaily = (InStr(dailyText, currentDailyHeader) > 0) 27 | 28 | If Not isTodayDaily Then 29 | row = 4 30 | Do While Not IsEmpty(ws.Cells(row, "C")) 31 | ' 复制 G → I 32 | ws.Cells(row, "I").Value = ws.Cells(row, "G").Value 33 | 34 | ' 清空 C, D, E, G, H 35 | ws.Cells(row, "C").ClearContents 36 | ws.Cells(row, "D").ClearContents 37 | ws.Cells(row, "E").ClearContents 38 | ws.Cells(row, "G").ClearContents 39 | ws.Cells(row, "H").ClearContents 40 | 41 | row = row + 1 42 | Loop 43 | End If 44 | 45 | ' ==== 处理每周（K2） ==== 46 | Dim weeklyText As String: weeklyText = ws.Range("K2").Value 47 | Dim startText As String, endText As String 48 | Dim startDate As Date, endDate As Date 49 | Dim thisMonday As Date, thisSunday As Date 50 | Dim y As Integer 51 | 52 | If InStr(weeklyText, "每周（") > 0 Then 53 | startText = Mid(weeklyText, InStr(weeklyText, "（") + 1, InStr(weeklyText, "-") - InStr(weeklyText, "（") - 1) 54 | endText = Mid(weeklyText, InStr(weeklyText, "-") + 1, InStr(weeklyText, "）") - InStr(weeklyText, "-") - 1) 55 | 56 | y = Year(today) 57 | startDate = DateSerial(y, CInt(Split(startText, ".")(0)), CInt(Split(startText, ".")(1))) 58 | endDate = DateSerial(y, CInt(Split(endText, ".")(0)), CInt(Split(endText, ".")(1))) 59 | 60 | thisMonday = today - Weekday(today, vbMonday) + 1 61 | thisSunday = thisMonday + 6 62 | 63 | If Not (today >= startDate And today <= endDate) Then 64 | row = 4 65 | Do While Not IsEmpty(ws.Cells(row, "K")) 66 | ' 复制 O → P 67 | ws.Cells(row, "P").Value = ws.Cells(row, "O").Value 68 | ' 清空 K:L:M:N:O 69 | ws.Range(ws.Cells(row, "K"), ws.Cells(row, "O")).ClearContents 70 | row = row + 1 71 | Loop 72 | End If 73 | End If 74 | 75 | ' ==== 处理每月（R2） ==== 76 | Dim monthlyText As String: monthlyText = ws.Range("R2").Value 77 | Dim monthNum As Integer 78 | Dim todayMonthStart As Date, todayMonthEnd As Date 79 | 80 | If InStr(monthlyText, "每月（") > 0 Then 81 | monthNum = CInt(Replace(Replace(monthlyText, "每月（", ""), "月）", "")) 82 | todayMonthStart = DateSerial(Year(today), monthNum, 1) 83 | todayMonthEnd = DateSerial(Year(today), monthNum + 1, 0) 84 | 85 | If Not (today >= todayMonthStart And today <= todayMonthEnd) Then 86 | row = 4 87 | Do While Not IsEmpty(ws.Cells(row, "R")) 88 | ' 复制 V → W 89 | ws.Cells(row, "W").Value = ws.Cells(row, "V").Value 90 | ' 清空 R:S:T:U:V 91 | ws.Range(ws.Cells(row, "R"), ws.Cells(row, "V")).ClearContents 92 | row = row + 1 93 | Loop 94 | End If 95 | End If 96 | 97 | ' ==== 执行结束后，在 C2 加“(正在填写数据)” ==== 98 | ws.Range("C2").Value = currentDailyHeader & "(正在填写数据)" 99 | End Sub -------------------------------------------------------------------------------- /small/1.step.vba: -------------------------------------------------------------------------------- 1 | Sub StepOne() 2 | Dim ws As Worksheet 3 | Set ws = ThisWorkbook.Sheets("日监控表") 4 | 5 | Dim today As Date: today = Date 6 | Dim row As Long 7 | 8 | ' ==== 判断是否正在填写数据 ==== 9 | If InStr(ws.Range("C2").Value, "正在填写数据") > 0 Then 10 | MsgBox "请填写当天数据" 11 | Exit Sub 12 | End If 13 | 14 | ' ==== 判断是否已更新今日每日数据 ==== 15 | Dim currentDailyHeader As String 16 | currentDailyHeader = "每日（" & Month(today) & "." & Day(today) & "）" 17 | 18 | If ws.Range("C2").Value = currentDailyHeader Then 19 | MsgBox "当天日期数据已更新！" 20 | Exit Sub 21 | End If 22 | 23 | ' ==== 处理每日（C2） ==== 24 | Dim dailyText As String: dailyText = ws.Range("C2").Value 25 | Dim isTodayDaily As Boolean 26 | isTodayDaily = (InStr(dailyText, currentDailyHeader) > 0) 27 | 28 | If Not isTodayDaily Then 29 | row = 4 30 | Do While Not IsEmpty(ws.Cells(row, "C")) 31 | ' 复制 G → I 32 | ws.Cells(row, "I").Value = ws.Cells(row, "G").Value 33 | 34 | ' 清空 C, D, E, G, H 35 | ws.Cells(row, "C").ClearContents 36 | ws.Cells(row, "D").ClearContents 37 | ws.Cells(row, "E").ClearContents 38 | ws.Cells(row, "G").ClearContents 39 | ws.Cells(row, "H").ClearContents 40 | 41 | row = row + 1 42 | Loop 43 | End If 44 | 45 | ' ==== 处理每周（K2） ==== 46 | Dim weeklyText As String: weeklyText = ws.Range("K2").Value 47 | Dim startText As String, endText As String 48 | Dim startDate As Date, endDate As Date 49 | Dim thisMonday As Date, thisSunday As Date 50 | Dim y As Integer 51 | 52 | If InStr(weeklyText, "每周（") > 0 Then 53 | startText = Mid(weeklyText, InStr(weeklyText, "（") + 1, InStr(weeklyText, "-") - InStr(weeklyText, "（") - 1) 54 | endText = Mid(weeklyText, InStr(weeklyText, "-") + 1, InStr(weeklyText, "）") - InStr(weeklyText, "-") - 1) 55 | 56 | y = Year(today) 57 | startDate = DateSerial(y, CInt(Split(startText, ".")(0)), CInt(Split(startText, ".")(1))) 58 | endDate = DateSerial(y, CInt(Split(endText, ".")(0)), CInt(Split(endText, ".")(1))) 59 | 60 | thisMonday = today - Weekday(today, vbMonday) + 1 61 | thisSunday = thisMonday + 6 62 | 63 | If Not (today >= startDate And today <= endDate) Then 64 | row = 4 65 | Do While Not IsEmpty(ws.Cells(row, "K")) 66 | ' 复制 O → P 67 | ws.Cells(row, "P").Value = ws.Cells(row, "O").Value 68 | ' 清空 K:L:M:N:O 69 | ws.Range(ws.Cells(row, "K"), ws.Cells(row, "O")).ClearContents 70 | row = row + 1 71 | Loop 72 | End If 73 | End If 74 | 75 | ' ==== 处理每月（R2） ==== 76 | Dim monthlyText As String: monthlyText = ws.Range("R2").Value 77 | Dim monthNum As Integer 78 | Dim todayMonthStart As Date, todayMonthEnd As Date 79 | 80 | If InStr(monthlyText, "每月（") > 0 Then 81 | monthNum = CInt(Replace(Replace(monthlyText, "每月（", ""), "月）", "")) 82 | todayMonthStart = DateSerial(Year(today), monthNum, 1) 83 | todayMonthEnd = DateSerial(Year(today), monthNum + 1, 0) 84 | 85 | If Not (today >= todayMonthStart And today <= todayMonthEnd) Then 86 | row = 4 87 | Do While Not IsEmpty(ws.Cells(row, "R")) 88 | ' 复制 V → W 89 | ws.Cells(row, "W").Value = ws.Cells(row, "V").Value 90 | ' 清空 R:S:T:U:V 91 | ws.Range(ws.Cells(row, "R"), ws.Cells(row, "V")).ClearContents 92 | row = row + 1 93 | Loop 94 | End If 95 | End If 96 | 97 | ' ==== 执行结束后，在 C2 加“(正在填写数据)” ==== 98 | ws.Range("C2").Value = currentDailyHeader & "(正在填写数据)" 99 | End Sub -------------------------------------------------------------------------------- /offsite/2.step.txt: -------------------------------------------------------------------------------- 1 | Function GetMergedLastRow(startCell As Range) As Long 2 | Dim rng As Range 3 | Dim lastRow As Long 4 | 5 | Set rng = startCell 6 | 7 | If rng.MergeCells Then 8 | lastRow = rng.MergeArea.Row + rng.MergeArea.Rows.Count - 1 9 | Else 10 | lastRow = 0 11 | End If 12 | 13 | GetMergedLastRow = lastRow 14 | End Function 15 | 16 | Function GetTongPeiMergedRows(ws As Worksheet, startRow As Long, endRow As Long) As Variant 17 | Dim cell As Range 18 | Dim rng As Range 19 | Dim startRowFound As Long, endRowFound As Long 20 | 21 | For Each cell In ws.Range(ws.Cells(startRow, "A"), ws.Cells(endRow, "A")) 22 | If cell.MergeCells Then 23 | Set rng = cell.MergeArea 24 | If InStr(cell.Value, "通赔组") > 0 Then 25 | startRowFound = rng.Row 26 | endRowFound = rng.Row + rng.Rows.Count - 1 27 | GetTongPeiMergedRows = Array(startRowFound, endRowFound) 28 | Exit Function 29 | End If 30 | End If 31 | Next cell 32 | 33 | GetTongPeiMergedRows = Array(0, 0) 34 | End Function 35 | 36 | Sub StepTwo() 37 | Dim ws As Worksheet 38 | Dim row As Long, lastRow As Long 39 | Dim fieldsDaily As Variant, fieldsWeekly As Variant, fieldsMonthly As Variant 40 | Dim fieldsStatsSrc As Variant, fieldsStatsDest As Variant 41 | Dim i As Integer 42 | Dim formulaText As String 43 | Dim newDivisor As Integer 44 | Dim today As Date 45 | Dim startOfWeek As Date 46 | Dim endOfWeek As Date 47 | Dim currentDailyHeader As String 48 | 49 | Dim tongPeiRange As Variant 50 | Dim tongPeiStartRow As Long, tongPeiEndRow As Long, tongPeiCount As Long 51 | Dim colCheck As Variant 52 | Dim r As Long, c As Integer 53 | 54 | Dim separators As Variant 55 | Dim sep As Variant 56 | Dim parts As Variant 57 | Dim cellVal As String 58 | Dim foundValidFormat As Boolean 59 | Dim allRowsValidFormat As Boolean 60 | 61 | Set ws = ThisWorkbook.Sheets("日监控表") 62 | 63 | today = Date 64 | currentDailyHeader = "每日（" & Month(today) & "." & Day(today) & "）" 65 | 66 | If ws.Range("C2").Value = currentDailyHeader Then 67 | MsgBox "当天日期数据已更新！" 68 | Exit Sub 69 | End If 70 | 71 | ' 获取“通赔组”区域行数 72 | tongPeiRange = GetTongPeiMergedRows(ws, 1, 1000) 73 | tongPeiStartRow = tongPeiRange(0) 74 | tongPeiEndRow = tongPeiRange(1) 75 | If tongPeiStartRow = 0 Or tongPeiEndRow = 0 Then 76 | MsgBox "未找到“通赔组”合并单元格，请检查A列内容！" 77 | Exit Sub 78 | End If 79 | 80 | Randomize 81 | separators = Array("-", ".", "@", " ") 82 | allRowsValidFormat = True 83 | 84 | ' 先检查所有行的C列是否都符合“分隔成4个数字”的格式 85 | For r = tongPeiStartRow To tongPeiEndRow - 1 86 | cellVal = Trim(ws.Cells(r, "C").Value) 87 | foundValidFormat = False 88 | 89 | If cellVal <> "" Then 90 | For Each sep In separators 91 | parts = Split(cellVal, sep) 92 | If UBound(parts) = 3 Then 93 | If IsNumeric(parts(0)) And IsNumeric(parts(1)) And IsNumeric(parts(2)) And IsNumeric(parts(3)) Then 94 | foundValidFormat = True 95 | Exit For 96 | End If 97 | End If 98 | Next sep 99 | End If 100 | 101 | If Not foundValidFormat Then 102 | allRowsValidFormat = False 103 | MsgBox "第 " & r & " 个人员的数据格式不正确，请检查（必须是4个数字，中间由 -, . , @ 或空格分隔）！", vbExclamation 104 | Exit Sub 105 | End If 106 | Next r 107 | 108 | If allRowsValidFormat Then 109 | ' 如果所有行的 C 都满足格式，则写入分解结果 + 随机 D 110 | For r = tongPeiStartRow To tongPeiEndRow - 1 111 | cellVal = Trim(ws.Cells(r, "C").Value) 112 | For Each sep In separators 113 | parts = Split(cellVal, sep) 114 | If UBound(parts) = 3 Then 115 | If IsNumeric(parts(0)) And IsNumeric(parts(1)) And IsNumeric(parts(2)) And IsNumeric(parts(3)) Then 116 | ws.Cells(r, "E").Value = CLng(parts(0)) 117 | ws.Cells(r, "G").Value = CLng(parts(1)) 118 | ws.Cells(r, "H").Value = CLng(parts(2)) 119 | ws.Cells(r, "C").Value = CLng(parts(3)) 120 | ws.Cells(r, "D").Value = Int(4 * Rnd + 20) 121 | Exit For 122 | End If 123 | End If 124 | Next sep 125 | Next r 126 | Else 127 | ' 否则按传统检查全部列 128 | For r = tongPeiStartRow To tongPeiEndRow - 1 129 | For c = 0 To UBound(colCheck) 130 | If Trim(ws.Cells(r, colCheck(c)).Value) = "" Then 131 | MsgBox "第 " & r & " 行，列 " & colCheck(c) & " 未填写数据，请补全后再运行！", vbExclamation 132 | Exit Sub 133 | End If 134 | Next c 135 | Next r 136 | End If 137 | 138 | ' 后续累计处理 139 | row = 4 140 | fieldsDaily = Array("C", "D", "E", "G", "H") 141 | fieldsWeekly = Array("K", "L", "M", "N", "O") 142 | fieldsMonthly = Array("R", "S", "T", "U", "V") 143 | fieldsStatsSrc = Array("C", "E", "G", "H") 144 | fieldsStatsDest = Array("Y", "Z", "AA", "AB") 145 | 146 | Do While Not IsEmpty(ws.Cells(row, "C")) 147 | For i = 0 To 4 148 | ws.Cells(row, fieldsWeekly(i)).Value = Val(ws.Cells(row, fieldsDaily(i)).Value) + Val(ws.Cells(row, fieldsWeekly(i)).Value) 149 | ws.Cells(row, fieldsMonthly(i)).Value = Val(ws.Cells(row, fieldsDaily(i)).Value) + Val(ws.Cells(row, fieldsMonthly(i)).Value) 150 | Next i 151 | 152 | For i = 0 To 3 153 | ws.Cells(row, fieldsStatsDest(i)).Value = Val(ws.Cells(row, fieldsStatsSrc(i)).Value) + Val(ws.Cells(row, fieldsStatsDest(i)).Value) 154 | Next i 155 | 156 | formulaText = ws.Cells(row, "AC").Formula 157 | If formulaText Like "=AA*/*" Then 158 | newDivisor = Val(Split(formulaText, "/")(1)) + 1 159 | ws.Cells(row, "AC").Formula = "=AA" & row & "/" & newDivisor 160 | End If 161 | 162 | formulaText = ws.Cells(row, "AD").Formula 163 | If formulaText Like "=AB*/*" Then 164 | newDivisor = Val(Split(formulaText, "/")(1)) + 1 165 | ws.Cells(row, "AD").Formula = "=AB" & row & "/" & newDivisor 166 | End If 167 | 168 | row = row + 1 169 | Loop 170 | 171 | lastRow = GetMergedLastRow(ws.Range("A4")) 172 | If lastRow = 0 Then 173 | MsgBox "未找到合并的合计行，请检查A4单元格是否合并！" 174 | Exit Sub 175 | End If 176 | 177 | Dim sumCols As Variant, sumCol As Variant 178 | sumCols = Array("C", "D", "E", "G", "H", "I", "K", "L", "M", "N", "O", "P", _ 179 | "R", "S", "T", "U", "V", "W", "Y", "Z", "AA", "AB") 180 | For Each sumCol In sumCols 181 | ws.Cells(lastRow, sumCol).Formula = "=SUM(" & sumCol & "4:" & sumCol & (lastRow - 1) & ")" 182 | Next sumCol 183 | 184 | ws.Cells(lastRow, "F").Formula = "=IF(D" & lastRow & "=0,0,E" & lastRow & "/D" & lastRow & ")" 185 | ws.Cells(lastRow, "J").Formula = "=IF(I" & lastRow & "=0,0,(G" & lastRow & "-I" & lastRow & ")/I" & lastRow & ")" 186 | ws.Cells(lastRow, "Q").Formula = "=IF(P" & lastRow & "=0,0,(N" & lastRow & "-P" & lastRow & ")/P" & lastRow & ")" 187 | ws.Cells(lastRow, "X").Formula = "=IF(W" & lastRow & "=0,0,(U" & lastRow & "-W" & lastRow & ")/W" & lastRow & ")" 188 | 189 | tongPeiCount = tongPeiEndRow - tongPeiStartRow 190 | 191 | formulaText = ws.Cells(lastRow, "AC").Formula 192 | If InStr(formulaText, "AA") > 0 Then 193 | Dim wd1 As Long 194 | On Error Resume Next 195 | wd1 = Val(Split(Split(formulaText, "/")(1), ")")(0)) 196 | If wd1 > 0 Then 197 | ws.Cells(lastRow, "AC").Formula = "=(AA" & lastRow & "/" & (wd1 + 1) & ")/" & tongPeiCount 198 | End If 199 | On Error GoTo 0 200 | End If 201 | 202 | formulaText = ws.Cells(lastRow, "AD").Formula 203 | If InStr(formulaText, "AB") > 0 Then 204 | Dim wd2 As Long 205 | On Error Resume Next 206 | wd2 = Val(Split(Split(formulaText, "/")(1), ")")(0)) 207 | If wd2 > 0 Then 208 | ws.Cells(lastRow, "AD").Formula = "=(AB" & lastRow & "/" & (wd2 + 1) & ")/" & tongPeiCount 209 | End If 210 | On Error GoTo 0 211 | End If 212 | 213 | ws.Range("C2").Value = currentDailyHeader 214 | startOfWeek = today - Weekday(today, vbMonday) + 1 215 | endOfWeek = startOfWeek + 6 216 | ws.Range("K2").Value = "每周（" & Month(startOfWeek) & "." & Day(startOfWeek) & "-" & Month(endOfWeek) & "." & Day(endOfWeek) & "）" 217 | ws.Range("R2").Value = "每月（" & Month(today) & "月）" 218 | End Sub -------------------------------------------------------------------------------- /offsite/2.step.vba: -------------------------------------------------------------------------------- 1 | Function GetMergedLastRow(startCell As Range) As Long 2 | Dim rng As Range 3 | Dim lastRow As Long 4 | 5 | Set rng = startCell 6 | 7 | If rng.MergeCells Then 8 | lastRow = rng.MergeArea.Row + rng.MergeArea.Rows.Count - 1 9 | Else 10 | lastRow = 0 11 | End If 12 | 13 | GetMergedLastRow = lastRow 14 | End Function 15 | 16 | Function GetTongPeiMergedRows(ws As Worksheet, startRow As Long, endRow As Long) As Variant 17 | Dim cell As Range 18 | Dim rng As Range 19 | Dim startRowFound As Long, endRowFound As Long 20 | 21 | For Each cell In ws.Range(ws.Cells(startRow, "A"), ws.Cells(endRow, "A")) 22 | If cell.MergeCells Then 23 | Set rng = cell.MergeArea 24 | If InStr(cell.Value, "通赔组") > 0 Then 25 | startRowFound = rng.Row 26 | endRowFound = rng.Row + rng.Rows.Count - 1 27 | GetTongPeiMergedRows = Array(startRowFound, endRowFound) 28 | Exit Function 29 | End If 30 | End If 31 | Next cell 32 | 33 | GetTongPeiMergedRows = Array(0, 0) 34 | End Function 35 | 36 | Sub StepTwo() 37 | Dim ws As Worksheet 38 | Dim row As Long, lastRow As Long 39 | Dim fieldsDaily As Variant, fieldsWeekly As Variant, fieldsMonthly As Variant 40 | Dim fieldsStatsSrc As Variant, fieldsStatsDest As Variant 41 | Dim i As Integer 42 | Dim formulaText As String 43 | Dim newDivisor As Integer 44 | Dim today As Date 45 | Dim startOfWeek As Date 46 | Dim endOfWeek As Date 47 | Dim currentDailyHeader As String 48 | 49 | Dim tongPeiRange As Variant 50 | Dim tongPeiStartRow As Long, tongPeiEndRow As Long, tongPeiCount As Long 51 | Dim colCheck As Variant 52 | Dim r As Long, c As Integer 53 | 54 | Dim separators As Variant 55 | Dim sep As Variant 56 | Dim parts As Variant 57 | Dim cellVal As String 58 | Dim foundValidFormat As Boolean 59 | Dim allRowsValidFormat As Boolean 60 | 61 | Set ws = ThisWorkbook.Sheets("日监控表") 62 | 63 | today = Date 64 | currentDailyHeader = "每日（" & Month(today) & "." & Day(today) & "）" 65 | 66 | If ws.Range("C2").Value = currentDailyHeader Then 67 | MsgBox "当天日期数据已更新！" 68 | Exit Sub 69 | End If 70 | 71 | ' 获取“通赔组”区域行数 72 | tongPeiRange = GetTongPeiMergedRows(ws, 1, 1000) 73 | tongPeiStartRow = tongPeiRange(0) 74 | tongPeiEndRow = tongPeiRange(1) 75 | If tongPeiStartRow = 0 Or tongPeiEndRow = 0 Then 76 | MsgBox "未找到“通赔组”合并单元格，请检查A列内容！" 77 | Exit Sub 78 | End If 79 | 80 | Randomize 81 | separators = Array("-", ".", "@", " ") 82 | allRowsValidFormat = True 83 | 84 | ' 先检查所有行的C列是否都符合“分隔成4个数字”的格式 85 | For r = tongPeiStartRow To tongPeiEndRow - 1 86 | cellVal = Trim(ws.Cells(r, "C").Value) 87 | foundValidFormat = False 88 | 89 | If cellVal <> "" Then 90 | For Each sep In separators 91 | parts = Split(cellVal, sep) 92 | If UBound(parts) = 3 Then 93 | If IsNumeric(parts(0)) And IsNumeric(parts(1)) And IsNumeric(parts(2)) And IsNumeric(parts(3)) Then 94 | foundValidFormat = True 95 | Exit For 96 | End If 97 | End If 98 | Next sep 99 | End If 100 | 101 | If Not foundValidFormat Then 102 | allRowsValidFormat = False 103 | MsgBox "第 " & r & " 个人员的数据格式不正确，请检查（必须是4个数字，中间由 -, . , @ 或空格分隔）！", vbExclamation 104 | Exit Sub 105 | End If 106 | Next r 107 | 108 | If allRowsValidFormat Then 109 | ' 如果所有行的 C 都满足格式，则写入分解结果 + 随机 D 110 | For r = tongPeiStartRow To tongPeiEndRow - 1 111 | cellVal = Trim(ws.Cells(r, "C").Value) 112 | For Each sep In separators 113 | parts = Split(cellVal, sep) 114 | If UBound(parts) = 3 Then 115 | If IsNumeric(parts(0)) And IsNumeric(parts(1)) And IsNumeric(parts(2)) And IsNumeric(parts(3)) Then 116 | ws.Cells(r, "E").Value = CLng(parts(0)) 117 | ws.Cells(r, "G").Value = CLng(parts(1)) 118 | ws.Cells(r, "H").Value = CLng(parts(2)) 119 | ws.Cells(r, "C").Value = CLng(parts(3)) 120 | ws.Cells(r, "D").Value = Int(4 * Rnd + 20) 121 | Exit For 122 | End If 123 | End If 124 | Next sep 125 | Next r 126 | Else 127 | ' 否则按传统检查全部列 128 | For r = tongPeiStartRow To tongPeiEndRow - 1 129 | For c = 0 To UBound(colCheck) 130 | If Trim(ws.Cells(r, colCheck(c)).Value) = "" Then 131 | MsgBox "第 " & r & " 行，列 " & colCheck(c) & " 未填写数据，请补全后再运行！", vbExclamation 132 | Exit Sub 133 | End If 134 | Next c 135 | Next r 136 | End If 137 | 138 | ' 后续累计处理 139 | row = 4 140 | fieldsDaily = Array("C", "D", "E", "G", "H") 141 | fieldsWeekly = Array("K", "L", "M", "N", "O") 142 | fieldsMonthly = Array("R", "S", "T", "U", "V") 143 | fieldsStatsSrc = Array("C", "E", "G", "H") 144 | fieldsStatsDest = Array("Y", "Z", "AA", "AB") 145 | 146 | Do While Not IsEmpty(ws.Cells(row, "C")) 147 | For i = 0 To 4 148 | ws.Cells(row, fieldsWeekly(i)).Value = Val(ws.Cells(row, fieldsDaily(i)).Value) + Val(ws.Cells(row, fieldsWeekly(i)).Value) 149 | ws.Cells(row, fieldsMonthly(i)).Value = Val(ws.Cells(row, fieldsDaily(i)).Value) + Val(ws.Cells(row, fieldsMonthly(i)).Value) 150 | Next i 151 | 152 | For i = 0 To 3 153 | ws.Cells(row, fieldsStatsDest(i)).Value = Val(ws.Cells(row, fieldsStatsSrc(i)).Value) + Val(ws.Cells(row, fieldsStatsDest(i)).Value) 154 | Next i 155 | 156 | formulaText = ws.Cells(row, "AC").Formula 157 | If formulaText Like "=AA*/*" Then 158 | newDivisor = Val(Split(formulaText, "/")(1)) + 1 159 | ws.Cells(row, "AC").Formula = "=AA" & row & "/" & newDivisor 160 | End If 161 | 162 | formulaText = ws.Cells(row, "AD").Formula 163 | If formulaText Like "=AB*/*" Then 164 | newDivisor = Val(Split(formulaText, "/")(1)) + 1 165 | ws.Cells(row, "AD").Formula = "=AB" & row & "/" & newDivisor 166 | End If 167 | 168 | row = row + 1 169 | Loop 170 | 171 | lastRow = GetMergedLastRow(ws.Range("A4")) 172 | If lastRow = 0 Then 173 | MsgBox "未找到合并的合计行，请检查A4单元格是否合并！" 174 | Exit Sub 175 | End If 176 | 177 | Dim sumCols As Variant, sumCol As Variant 178 | sumCols = Array("C", "D", "E", "G", "H", "I", "K", "L", "M", "N", "O", "P", _ 179 | "R", "S", "T", "U", "V", "W", "Y", "Z", "AA", "AB") 180 | For Each sumCol In sumCols 181 | ws.Cells(lastRow, sumCol).Formula = "=SUM(" & sumCol & "4:" & sumCol & (lastRow - 1) & ")" 182 | Next sumCol 183 | 184 | ws.Cells(lastRow, "F").Formula = "=IF(D" & lastRow & "=0,0,E" & lastRow & "/D" & lastRow & ")" 185 | ws.Cells(lastRow, "J").Formula = "=IF(I" & lastRow & "=0,0,(G" & lastRow & "-I" & lastRow & ")/I" & lastRow & ")" 186 | ws.Cells(lastRow, "Q").Formula = "=IF(P" & lastRow & "=0,0,(N" & lastRow & "-P" & lastRow & ")/P" & lastRow & ")" 187 | ws.Cells(lastRow, "X").Formula = "=IF(W" & lastRow & "=0,0,(U" & lastRow & "-W" & lastRow & ")/W" & lastRow & ")" 188 | 189 | tongPeiCount = tongPeiEndRow - tongPeiStartRow 190 | 191 | formulaText = ws.Cells(lastRow, "AC").Formula 192 | If InStr(formulaText, "AA") > 0 Then 193 | Dim wd1 As Long 194 | On Error Resume Next 195 | wd1 = Val(Split(Split(formulaText, "/")(1), ")")(0)) 196 | If wd1 > 0 Then 197 | ws.Cells(lastRow, "AC").Formula = "=(AA" & lastRow & "/" & (wd1 + 1) & ")/" & tongPeiCount 198 | End If 199 | On Error GoTo 0 200 | End If 201 | 202 | formulaText = ws.Cells(lastRow, "AD").Formula 203 | If InStr(formulaText, "AB") > 0 Then 204 | Dim wd2 As Long 205 | On Error Resume Next 206 | wd2 = Val(Split(Split(formulaText, "/")(1), ")")(0)) 207 | If wd2 > 0 Then 208 | ws.Cells(lastRow, "AD").Formula = "=(AB" & lastRow & "/" & (wd2 + 1) & ")/" & tongPeiCount 209 | End If 210 | On Error GoTo 0 211 | End If 212 | 213 | ws.Range("C2").Value = currentDailyHeader 214 | startOfWeek = today - Weekday(today, vbMonday) + 1 215 | endOfWeek = startOfWeek + 6 216 | ws.Range("K2").Value = "每周（" & Month(startOfWeek) & "." & Day(startOfWeek) & "-" & Month(endOfWeek) & "." & Day(endOfWeek) & "）" 217 | ws.Range("R2").Value = "每月（" & Month(today) & "月）" 218 | End Sub -------------------------------------------------------------------------------- /small/2.step.vba: -------------------------------------------------------------------------------- 1 | ' 在模块顶部添加（或放在一个专用模块里） 2 | Public Type GroupInfo 3 | AStartRow As Long 4 | AEndRow As Long 5 | ACount As Long 6 | BStartRow As Long 7 | BEndRow As Long 8 | BCount As Long 9 | TotalRow As Long 10 | DailyText As String 11 | WeeklyText As String 12 | MonthlyText As String 13 | End Type 14 | 15 | Function GetMonitorSheetInfo() As GroupInfo 16 | Dim info As GroupInfo 17 | Dim ws As Worksheet 18 | Set ws = ThisWorkbook.Sheets("日监控表") 19 | 20 | Dim lastRow As Long 21 | lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row 22 | 23 | Dim i As Long 24 | Dim aGroupStartRow As Long, aGroupEndRow As Long 25 | Dim bGroupStartRow As Long, bGroupEndRow As Long 26 | 27 | ' 查找 A组 和 B组 起始行 28 | For i = 1 To lastRow 29 | If ws.Cells(i, 2).MergeCells Then 30 | If ws.Cells(i, 2).Value = "A组" And aGroupStartRow = 0 Then 31 | aGroupStartRow = ws.Cells(i, 2).MergeArea.Row 32 | aGroupEndRow = ws.Cells(i, 2).MergeArea.Row + ws.Cells(i, 2).MergeArea.Rows.Count - 1 33 | ElseIf ws.Cells(i, 2).Value = "B组" And bGroupStartRow = 0 Then 34 | bGroupStartRow = ws.Cells(i, 2).MergeArea.Row 35 | bGroupEndRow = ws.Cells(i, 2).MergeArea.Row + ws.Cells(i, 2).MergeArea.Rows.Count - 1 36 | End If 37 | Else 38 | If ws.Cells(i, 2).Value = "A组" And aGroupStartRow = 0 Then 39 | aGroupStartRow = i 40 | ElseIf ws.Cells(i, 2).Value = "B组" And bGroupStartRow = 0 Then 41 | bGroupStartRow = i 42 | End If 43 | End If 44 | Next i 45 | 46 | ' 找 A组 合计行 47 | If aGroupEndRow > 0 Then 48 | For i = aGroupEndRow + 1 To lastRow 49 | If ws.Cells(i, 2).Value = "合计" Then 50 | aGroupEndRow = i 51 | Exit For 52 | End If 53 | Next i 54 | End If 55 | 56 | ' 找 B组 合计行 57 | If bGroupEndRow > 0 Then 58 | For i = bGroupEndRow + 1 To lastRow 59 | If ws.Cells(i, 2).Value = "合计" Then 60 | bGroupEndRow = i 61 | Exit For 62 | End If 63 | Next i 64 | End If 65 | 66 | ' 填充结构体 67 | info.AStartRow = aGroupStartRow ' A组开始行 68 | info.AEndRow = aGroupEndRow ' A组结束行 69 | info.ACount = aGroupEndRow - aGroupStartRow ' A组人数 70 | 71 | info.BStartRow = bGroupStartRow ' B组开始行 72 | info.BEndRow = bGroupEndRow ' B组结束行（合计行） 73 | info.BCount = bGroupEndRow - bGroupStartRow ' B组人数 74 | 75 | info.TotalRow = bGroupEndRow + 1 ' 总合计行 76 | 77 | info.DailyText = ws.Range("D2").Text 78 | info.WeeklyText = ws.Range("L2").Text 79 | info.MonthlyText = ws.Range("R2").Text 80 | 81 | GetMonitorSheetInfo = info 82 | End Function 83 | 84 | Sub PrepareNewDayEntry() 85 | Dim i As Long 86 | Dim info As GroupInfo 87 | info = GetMonitorSheetInfo() 88 | 89 | Dim ws As Worksheet 90 | Set ws = ThisWorkbook.Sheets("日监控表") 91 | 92 | Dim today As Date 93 | today = Date 94 | 95 | ' === 每日处理 === 96 | Dim todayTag As String 97 | todayTag = "每日（" & Month(today) & "." & Day(today) & "）" 98 | 99 | If ws.Range("D2").Value <> todayTag Then 100 | ' 修改 D2 内容为 原值（正在填写新数据） 101 | Dim oldText As String 102 | oldText = ws.Range("D2").Value 103 | ws.Range("D2").Value = oldText & "（正在填写新数据）" 104 | 105 | ' A组 106 | For i = info.AStartRow To info.AEndRow - 1 107 | ws.Cells(i, "J").Value = ws.Cells(i, "H").Value 108 | ws.Cells(i, "D").ClearContents 109 | ws.Cells(i, "E").ClearContents 110 | ws.Cells(i, "G").ClearContents 111 | ws.Cells(i, "H").ClearContents 112 | Next i 113 | 114 | ' B组 115 | For i = info.BStartRow To info.BEndRow - 1 116 | ws.Cells(i, "J").Value = ws.Cells(i, "H").Value 117 | ws.Cells(i, "D").ClearContents 118 | ws.Cells(i, "E").ClearContents 119 | ws.Cells(i, "G").ClearContents 120 | ws.Cells(i, "H").ClearContents 121 | Next i 122 | End If 123 | 124 | For i = info.AStartRow To info.AEndRow - 1 125 | ws.Cells(i, "F").Formula = "=IF(D" & i & "=0,0,E" & i & "/D" & i & ")" 126 | ws.Cells(i, "I").Formula = "=IF(H" & i & "=0,0,G" & i & "/H" & i & ")" 127 | ws.Cells(i, "K").Formula = "=IF(J" & i & "=0,-1,(H" & i & "-J" & i & ")/J" & i & ")" 128 | Next i 129 | 130 | For i = info.BStartRow To info.BEndRow - 1 131 | ws.Cells(i, "F").Formula = "=IF(D" & i & "=0,0,E" & i & "/D" & i & ")" 132 | ws.Cells(i, "I").Formula = "=IF(H" & i & "=0,0,G" & i & "/H" & i & ")" 133 | ws.Cells(i, "K").Formula = "=IF(J" & i & "=0,-1,(H" & i & "-J" & i & ")/J" & i & ")" 134 | Next i 135 | 136 | ' 合计行（A组） 137 | ws.Cells(info.AEndRow, "J").Formula = "=SUM(J" & info.AStartRow & ":J" & info.AEndRow - 1 & ")" 138 | ws.Cells(info.AEndRow, "I").Formula = "=IF(H" & info.AEndRow & "=0,0,G" & info.AEndRow & "/H" & info.AEndRow & ")" ' =IF(H4=0,0,G4/H4) 139 | ws.Cells(info.AEndRow, "F").Formula = "=IF(D" & info.AEndRow & "=0,0,E" & info.AEndRow & "/D" & info.AEndRow & ")" 140 | ws.Cells(info.AEndRow, "K").Formula = "=IF(J" & info.AEndRow & "=0,-1,(H" & info.AEndRow & "-J" & info.AEndRow & ")/J" & info.AEndRow & ")" 141 | 142 | ' 合计行（B组） 143 | ws.Cells(info.BEndRow, "J").Formula = "=SUM(J" & info.BStartRow & ":J" & info.BEndRow - 1 & ")" 144 | ws.Cells(info.BEndRow, "F").Formula = "=IF(H" & info.BEndRow & "=0,0,G" & info.BEndRow & "/H" & info.BEndRow & ")" 145 | ws.Cells(info.BEndRow, "I").Formula = "=IF(D" & info.BEndRow & "=0,0,E" & info.BEndRow & "/D" & info.BEndRow & ")" 146 | ws.Cells(info.BEndRow, "K").Formula = "=IF(J" & info.BEndRow & "=0,-1,(H" & info.BEndRow & "-J" & info.BEndRow & ")/J" & info.BEndRow & ")" 147 | 148 | ' 合计行（总合计） 149 | ws.Cells(info.TotalRow, "J").Formula = "=J" & info.AEndRow & " + J" & info.BEndRow 150 | ws.Cells(info.TotalRow, "F").Formula = "=F" & info.AEndRow & " + F" & info.BEndRow 151 | ws.Cells(info.TotalRow, "I").Formula = "=I" & info.AEndRow & " + I" & info.BEndRow 152 | ws.Cells(info.TotalRow, "K").Formula = "=IF(J" & info.TotalRow & "=0,-1,(H" & info.TotalRow & "-J" & info.TotalRow & ")/J" & info.TotalRow & ")" 153 | 154 | ' === 每周处理 === 155 | Dim weeklyText As String: weeklyText = ws.Range("L2").Value 156 | Dim startText As String, endText As String 157 | Dim startDate As Date, endDate As Date 158 | Dim y As Integer 159 | 160 | If InStr(weeklyText, "每周（") > 0 Then 161 | startText = Mid(weeklyText, InStr(weeklyText, "（") + 1, InStr(weeklyText, "-") - InStr(weeklyText, "（") - 1) 162 | endText = Mid(weeklyText, InStr(weeklyText, "-") + 1, InStr(weeklyText, "）") - InStr(weeklyText, "-") - 1) 163 | 164 | y = Year(today) 165 | startDate = DateSerial(y, CInt(Split(startText, ".")(0)), CInt(Split(startText, ".")(1))) 166 | endDate = DateSerial(y, CInt(Split(endText, ".")(0)), CInt(Split(endText, ".")(1))) 167 | 168 | ' 跨年情况处理 169 | If endDate < startDate Then 170 | endDate = DateSerial(y + 1, CInt(Split(endText, ".")(0)), CInt(Split(endText, ".")(1))) 171 | End If 172 | 173 | If Not (today >= startDate And today <= endDate) Then 174 | For i = info.AStartRow To info.AEndRow - 1 175 | ws.Cells(i, "P").Value = ws.Cells(i, "N").Value 176 | ws.Cells(i, "L").ClearContents 177 | ws.Cells(i, "M").ClearContents 178 | ws.Cells(i, "N").ClearContents 179 | Next i 180 | 181 | For i = info.BStartRow To info.BEndRow - 1 182 | ws.Cells(i, "P").Value = ws.Cells(i, "N").Value 183 | ws.Cells(i, "L").ClearContents 184 | ws.Cells(i, "M").ClearContents 185 | ws.Cells(i, "N").ClearContents 186 | Next i 187 | End If 188 | End If 189 | 190 | For i = info.AStartRow To info.AEndRow - 1 191 | ws.Cells(i, "O").Formula = "=IF(M" & i & "=0,0,N" & i & "/M" & i & ")" 192 | ws.Cells(i, "Q").Formula = "=IF(P" & i & "=0,-1,(N" & i & "-P" & i & ")/P" & i & ")" 193 | Next i 194 | 195 | For i = info.BStartRow To info.BEndRow - 1 196 | ws.Cells(i, "O").Formula = "=IF(M" & i & "=0,0,N" & i & "/M" & i & ")" 197 | ws.Cells(i, "Q").Formula = "=IF(P" & i & "=0,-1,(N" & i & "-P" & i & ")/P" & i & ")" 198 | Next i 199 | 200 | ' 合计行公式（A组） 201 | ws.Range("L" & info.AEndRow).Formula = "=SUM(L" & info.AStartRow & ":L" & info.AEndRow - 1 & ")" 202 | ws.Range("M" & info.AEndRow).Formula = "=SUM(M" & info.AStartRow & ":M" & info.AEndRow - 1 & ")" 203 | ws.Range("N" & info.AEndRow).Formula = "=SUM(N" & info.AStartRow & ":N" & info.AEndRow - 1 & ")" 204 | ws.Range("P" & info.AEndRow).Formula = "=SUM(P" & info.AStartRow & ":P" & info.AEndRow - 1 & ")" 205 | ws.Range("O" & info.AEndRow).Formula = "=IF(M" & info.AEndRow & "=0,0,N" & info.AEndRow & "/M" & info.AEndRow & ")" 206 | ws.Range("Q" & info.AEndRow).Formula = "=IF(P" & info.AEndRow & "=0,-1,(N" & info.AEndRow & "-P" & info.AEndRow & ")/P" & info.AEndRow & ")" 207 | 208 | ' 合计行公式（B组） 209 | ws.Range("L" & info.BEndRow).Formula = "=SUM(L" & info.BStartRow & ":L" & info.BEndRow - 1 & ")" 210 | ws.Range("M" & info.BEndRow).Formula = "=SUM(M" & info.BStartRow & ":M" & info.BEndRow - 1 & ")" 211 | ws.Range("N" & info.BEndRow).Formula = "=SUM(N" & info.BStartRow & ":N" & info.BEndRow - 1 & ")" 212 | ws.Range("P" & info.BEndRow).Formula = "=SUM(P" & info.BStartRow & ":P" & info.BEndRow - 1 & ")" 213 | ws.Range("O" & info.BEndRow).Formula = "=IF(M" & info.BEndRow & "=0,0,N" & info.BEndRow & "/M" & info.BEndRow & ")" 214 | ws.Range("Q" & info.BEndRow).Formula = "=IF(P" & info.BEndRow & "=0,-1,(N" & info.BEndRow & "-P" & info.BEndRow & ")/P" & info.BEndRow & ")" 215 | 216 | ' 总合计行（info.TotalRow） 217 | ws.Range("M" & info.TotalRow).Formula = "=M" & info.AEndRow & " + M" & info.BEndRow 218 | ws.Range("N" & info.TotalRow).Formula = "=N" & info.AEndRow & " + N" & info.BEndRow 219 | ws.Range("P" & info.TotalRow).Formula = "=P" & info.AEndRow & " + P" & info.BEndRow 220 | ws.Range("O" & info.TotalRow).Formula = "=IF(M" & info.TotalRow & "=0,0,N" & info.TotalRow & "/M" & info.TotalRow & ")" 221 | ws.Range("Q" & info.TotalRow).Formula = "=IF(P" & info.TotalRow & "=0,-1,(N" & info.TotalRow & "-P" & info.TotalRow & ")/P" & info.TotalRow & ")" 222 | End Sub 223 | 224 | Sub Run() 225 | Call PrepareNewDayEntry() 226 | End Sub 227 | --------------------------------------------------------------------------------