|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
本帖最后由 木木2018 于 2018-8-16 12:27 编辑
为了实现将一行记录，根据该记录中横跨的天数，按照日期拆分成几行记录。
原始数据是这样的
| 计划名称 | 培训项目 | 所属部门 | 工作部门 | 岗位 | 姓名 | 工号 | 性别 | 入职日期 | 员工状态 | 考核结果 | 培训开始时间 | 培训结束时间 | | 培训 | 培训 | 中南 | 中南 | 工程师 | 1 | G0218415 | 男 | 2018/5/2 | 试用期 | 合格 | 2018/7/29 | 2018/8/3 |
拆分后效果是这样的
| 计划名称 | 培训项目 | 所属部门 | 工作部门 | 岗位 | 姓名 | 工号 | 性别 | 入职日期 | 员工状态 | 考核结果 | 培训开始时间 | 培训结束时间 | | 培训 | 培训 | 中南 | 中南 | 工程师 | 1 | G0218415 | 男 | 2018/5/2 | 试用期 | 合格 | 2018/7/29 | 2018/7/29 | | 培训 | 培训 | 中南 | 中南 | 工程师 | 1 | G0218415 | 男 | 2018/5/2 | 试用期 | 合格 | 2018/7/30 | 2018/7/30 | | 培训 | 培训 | 中南 | 中南 | 工程师 | 1 | G0218415 | 男 | 2018/5/2 | 试用期 | 合格 | 2018/7/31 | 2018/7/31 | | 培训 | 培训 | 中南 | 中南 | 工程师 | 1 | G0218415 | 男 | 2018/5/2 | 试用期 | 合格 | 2018/8/1 | 2018/8/1 | | 培训 | 培训 | 中南 | 中南 | 工程师 | 1 | G0218415 | 男 | 2018/5/2 | 试用期 | 合格 | 2018/8/2 | 2018/8/2 | | 培训 | 培训 | 中南 | 中南 | 工程师 | 1 | G0218415 | 男 | 2018/5/2 | 试用期 | 合格 | 2018/8/3 | 2018/8/3 |
在论坛学习了一段代码过来，直接套用数据报错“”下标越界“”，尽我所能也没弄明白怎么解决，求大神帮帮忙处理一下，我每次需要处理的数据量在1000~5000条，但这个代码最多只能处理42条。
以下是代码和文档
Sub test()
Dim r%, i%
Dim arr, brr
With Worksheets("复制数据界面")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a3:x" & r)
ReDim brr(1 To 1000, 1 To UBound(arr, 2))
m = 0
For i = 1 To UBound(arr)
If arr(i, 12) = arr(i, 13) Then
m = m + 1
For j = 1 To UBound(arr, 2)
brr(m, j) = arr(i, j)
Next
Else
If arr(i, 12) < arr(i, 13) Then
For k = arr(i, 12) To arr(i, 13)
m = m + 1
For j = 1 To UBound(arr, 2)
brr(m, j) = arr(i, j)
Next
If k > arr(i, 12) Then
brr(m, 12) = k
brr(m, 13) = k
End If
Next
End If
End If
Next
End With
With Worksheets("输出结果")
.Select
.UsedRange.Offset(1, 0).ClearContents
.Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
End With
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2018-8-16 11:40
楼主