Excel·VBA多个日期期间是否重叠、连续

多个日期期间是否重叠

date_startend()函数需要调用排序函数bubble_sort()《Excel·VBA数组冒泡排序函数》

Function date_overlap(dates)'函数定义date_overlap(日期二维数组(开始日期，结束日期))，返回结果各日期期间重叠的日期(str/数组)'参数数组、返回数组从1开始计数Dim dict As Object, i&, j, n&, resultIf LBound(dates) = UBound(dates) Then date_overlap = "": Exit Function  '只有一组日期，返回空值Set dict = CreateObject("scripting.dictionary")If LBound(dates) = 0 Or LBound(dates, 2) = 0 Then  '参数检查、规范，转为从1开始计数dates = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dates))End IfFor i = 1 To UBound(dates):For j = dates(i, 1) To dates(i, 2):If Not dict.Exists(j) Then  '新键-值（日期-出现次数）dict(j) = 1Else  '已有键-值，更新dict(j) = dict(j) + 1End IfNextNextk = dict.keysv = dict.Items
'--------------------输出字符串
'    For i = 0 To dict.count - 1:  '遍历字典
'        If v(i) > 1 Then
'            'result = result & "，" & k(i)  '和以下mid()一起，mid报错
'            result = result & k(i) & "，"  '拼接重叠日期，末尾有"，"
'        End If
'    Next
'    date_overlap = result
'--------------------以下为输出数组result = Array()For i = 0 To dict.count - 1:  '遍历字典If v(i) > 1 Thenn = n + 1ReDim Preserve result(1 To n)  '重定义数组长度，但数据保留result(n) = k(i)End IfNextdict.RemoveAll  '清除字典，释放内存If UBound(result) <> -1 Then date_overlap = result Else date_overlap = ""
End FunctionFunction date_startend(dates)'函数定义date_startend(日期数组)对日期数组进行整理，如有连续日期则转换为起止日期形式，返回一个数组'参数数组为一维数组，返回一维数组从1开始计数Dim arr, temp, result, i&, j&If LBound(dates) = UBound(dates) Then date_startend = dates: Exit Function  '只有一个日期arr = bubble_sort(dates, "+")  '<调用排序函数>ReDim result(1 To UBound(arr) - LBound(arr) + 1)  '返回数组temp = Array("", "")  '临时起止日期For i = LBound(arr) To UBound(arr) - 1If temp(0) = "" Then temp(0) = arr(i): temp(1) = arr(i)If temp(1) = arr(i + 1) - 1 Then  '连续日期temp(1) = arr(i + 1)  '更新止日期Elsej = j + 1If temp(0) = temp(1) Thenresult(j) = temp(0): temp = Array("", "")  '返回数组赋值，重置temp数组Elseresult(j) = Join(temp, "-"): temp = Array("", "")End IfIf i = UBound(arr) - 1 Then j = j + 1: result(j) = arr(UBound(arr))  '最后一组单独日期End IfNextIf temp(0) <> temp(1) Then j = j + 1: result(j) = Join(temp, "-")  '最后一组连续日期If j < UBound(result) Then ReDim Preserve result(1 To j)  '重定义数组长度，但数据保留date_startend = result
End Function

举例

贴吧提问《如何在相同编码里，判断是否有日期重叠》，对多组日期期间是否有重叠的日期进行计算，参考贴子回复编写代码，使其更具通用性

Sub 日期期间重叠()Dim arr, brr, k, v, res, dict As ObjectSet dict = CreateObject("scripting.dictionary")arr = [a1].CurrentRegionFor i = 2 To UBound(arr):  '编码去重，统计出现次数，以便重新定义brr数组If Not dict.Exists(arr(i, 1)) Then  '新键-值dict(arr(i, 1)) = 1Elsedict(arr(i, 1)) = dict(arr(i, 1)) + 1End IfNextk = dict.keysv = dict.ItemsFor i = 0 To dict.count - 1:  '遍历字典ReDim brr(1 To v(i), 1 To 2)  '重新定义brr数组x = 1For j = 2 To UBound(arr):  '遍历arr数组If k(i) = arr(j, 1) Thenbrr(x, 1) = arr(j, 2): brr(x, 2) = arr(j, 3)  '赋值brr数组x = x + 1End IfNextres = date_overlap(brr)  '调用函数，获取结果row_write = [g1].CurrentRegion.Rows.count + 1  '输出结果区域的第一个空行写入
'--------------------字符串
'        If res <> "" Then  '写入结果
'            Cells(row_write, 7).Resize(1, 3) = Array(k(i), "是", res)
'        Else
'            Cells(row_write, 7).Resize(1, 3) = Array(k(i), "否", res)
'        End If
'--------------------数组
'        If IsArray(res) Then
'            Cells(row_write, 7).Resize(1, 3) = Array(k(i), "是", Join(res, ","))
'        Else
'            Cells(row_write, 7).Resize(1, 3) = Array(k(i), "否", "")
'        End If
'--------------------数组+起止日期If IsArray(res) ThenCells(row_write, 7).Resize(1, 3) = Array(k(i), "是", Join(date_startend(res), ","))ElseCells(row_write, 7).Resize(1, 3) = Array(k(i), "否", "")End IfNext
End Sub

多种写入形式

多个日期期间是否连续

Function date_discont(dates)'函数定义date_discont(日期二维数组(开始日期，结束日期))返回各日期期间不连续的日期数组'参数数组为二维数组，返回一维数组，数组都从1开始计数Dim dict As Object, result, i&, j&, n&, date_start, date_end, start_endIf LBound(dates) = UBound(dates) Then date_discont = "": Exit Function  '只有一组日期，返回空值Set dict = CreateObject("scripting.dictionary")If LBound(dates) = 0 Or LBound(dates, 2) = 0 Then  '参数检查、规范，转为从1开始计数dates = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dates))End Ifstart_end = Array("", "")For i = 1 To UBound(dates):  '日期二维数组中所有日期写入字典date_start = CDate(dates(i, 1)): date_end = CDate(dates(i, 2))For j = date_start To date_end:dict(j) = ""NextIf start_end(0) = "" Thenstart_end(0) = date_start: start_end(1) = date_endElseIf start_end(0) > date_start Then start_end(0) = date_startIf start_end(1) < date_end Then start_end(1) = date_endEnd IfNextReDim result(1 To start_end(1) - start_end(0))For i = start_end(0) To start_end(1)  '最大起止日期遍历，获取不在字典中的日期If Not dict.Exists(i) Thenn = n + 1: result(n) = CDate(i)End IfNextIf n < UBound(result) And n > 0 Then ReDim Preserve result(1 To n) '重定义数组长度，但数据保留If n <> 0 Then date_discont = result Else date_discont = ""
End Function

举例

代码基本与“Sub 日期期间重叠()”一致

Sub 日期期间不连续()Dim arr, brr, k, v, res, dict As ObjectSet dict = CreateObject("scripting.dictionary")arr = [a1].CurrentRegionFor i = 2 To UBound(arr):  '编码去重，统计出现次数，以便重新定义brr数组If Not dict.Exists(arr(i, 1)) Then  '新键-值dict(arr(i, 1)) = 1Elsedict(arr(i, 1)) = dict(arr(i, 1)) + 1End IfNextk = dict.keysv = dict.ItemsFor i = 0 To dict.count - 1:  '遍历字典ReDim brr(1 To v(i), 1 To 2)  '重新定义brr数组x = 1For j = 2 To UBound(arr):  '遍历arr数组If k(i) = arr(j, 1) Thenbrr(x, 1) = arr(j, 2): brr(x, 2) = arr(j, 3)  '赋值brr数组x = x + 1End IfNextres = date_discont(brr)  '调用函数，获取结果row_write = [g1].CurrentRegion.Rows.count + 1  '输出结果区域的第一个空行写入If IsArray(res) ThenCells(row_write, "g").Resize(1, 3) = Array(k(i), "否", Join(date_startend(res), ","))ElseCells(row_write, "g").Resize(1, 3) = Array(k(i), "是", "")End IfNext
End Sub

Excel·VBA多个日期期间是否重叠、连续相关推荐

excel vba 如何将日期周几转换成文字_Excel 从精通到入门
Excel 从精通到入门引子 Excel? 这么简单的东西有学的必要吗?公式加减乘除,诶等等这个日期怎么变成 #### 了,虽然文本数字搞不清楚,但也算熟练使用 Excel 啦. WOW, Awso ...
excel vba 如何将日期周几转换成文字_这5个超实用的Excel技巧，让你的办公效率更高...
导读:对于办公职员来说,Excel是几乎每天都会接触的办公软件.在Excel中,有非常多的小技巧,学习这些小技巧需要不断的积累和应用,今天指北针就来给大家分享5个超实用的Excel技巧,让办公变得更加 ...
Excel VBA：按日期汇总计算输出结果（sumif）
问题场景 1)按日期将C列的金额累计汇总 2)按日期和"支出/收入"汇总每日金额 PS:直接输出结果,不需要公式参数定义&函数说明参数定义: Range格式定义汇总范围 ...
Excel VBA高级编程 -根据日期查找数据
关注公众号:万能的Excel 并回复[日期搜索]获取源文件! 功能说明: 打印出货单的时候,经常会需要从数据库中查询一段时间内的所有数据本工作表使用VBA实现了如下功能: 1.实时统计重复项 ...
php时间期间检测重叠,如何检查PHP中多个日期范围之间的重叠？
关于检查两个日期之间的重叠有很多帖子.但是,我找不到任何关于如何在多个范围内进行检查的讨论. 说我有这个数组: $ranges = [ array('start'=>'2014-01-01' , ...
来吧！带你玩转 Excel VBA
来吧!带你玩转 Excel VBA(含CD光盘1张)(双色)(附带近500个VBA思考练习题,Exceltip.net出品) 罗刚君杨嘉恺编著 ISBN 978-7-121-20627-6 201 ...
来吧带你玩转 Excel VBA
分享一下我老师大神的人工智能教程!零基础,通俗易懂!http://blog.csdn.net/jiangjunshow 也欢迎大家转载本篇文章.分享知识,造福人民,实现我们中华民族伟大复兴! 来吧!带 ...
Excel+VBA+之快速上手
第一章 VBA语言基础第一节标识符一．定义标识符是一种标识变量.常量.过程.函数.类等语言构成单位的符号,利用它可以完成对变量.常量.过程.函数.类等的引用. 二．命名规则 1 ...
Excel VBA简单语法
摘要: 该文为想要学习VBA编程的会计和编程同学有使用VBA实现Excel自动化处理和一定的个性化定制Excel操作提供参考第一篇为::VBA简单语法第二篇为: Excel 编写第一个简单的VBA ...

Excel·VBA多个日期期间是否重叠、连续

目录

多个日期期间是否重叠

举例

多个日期期间是否连续

举例

Excel·VBA多个日期期间是否重叠、连续相关推荐

最新文章

热门文章