设为首页收藏本站

简字体切换切换到宽版

ExcelHome技术论坛»论坛 › Excel 技术交流与问答 › Excel VBA程序开发 › 考勤文件格式转换

EH技术汇-专业的职场技能充电站	妙哉！函数段子手趣味讲函数	Excel服务器-会Excel,做管理系统	Excel Home精品图文教程库
HR薪酬管理数字化实战	Excel 2021函数公式学习大典	Excel数据透视表实战秘技	打造核心竞争力的职场宝典
300集Office 2010微视频教程	数据工作者的案头书	免费直播课集锦	ExcelHome出品 - VBA代码宝免费下载
	用ChatGPT与VBA一键搞定Excel	WPS表格从入门到精通	Excel VBA经典代码实践指南

12 / 2 页下一页

发新帖

查看: 1740|回复: 11

[求助] 考勤文件格式转换

大太阳，心情好

TA的精华主题

TA的得分主题

发表于 2020-2-16 20:52 | 显示全部楼层 |阅读模式

[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★使用手册★

考勤文件格式转换，求帮助，谢谢谢谢谢。

考勤, 文件, 文件格式, 格式, 转换

12.2 KB, 下载次数: 13

回复

TA的精华主题

TA的得分主题

发表于 2020-2-17 08:11 | 显示全部楼层

[广告] ★会Excel,就能做支持PC、手机、Web、App、Windows、安卓、IOS、Linux信息一体化的各种管理系统 ★

Sub 按钮2_Click()
Dim brr()
arr = Sheets(1).UsedRange
ReDim brr(1 To UBound(arr) * UBound(arr, 2) * 2, 1 To 4)
r = 0
str1 = Split(arr(1, 1), "考勤表")(0)
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "\d+:\d+"
For j = 3 To UBound(arr)
For i = 3 To 33
If Len(arr(j, i)) > 0 Then
For Each m In .Execute(arr(j, i))
r = r + 1
brr(r, 1) = arr(j, 1)
brr(r, 3) = arr(j, 2)
brr(r, 4) = CDate(str1 & arr(2, i) & "日") + CDate(m.Value)
Next m
End If
Next i
Next j
End With
Sheets(2).[a1].CurrentRegion.Offset(1).ClearContents
If r > 0 Then Sheets(2).[a2].Resize(r, 4) = brr
End Sub

复制代码

回复

TA的精华主题

TA的得分主题

发表于 2020-2-17 08:11 | 显示全部楼层

[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★使用手册★

附件内容供参考。。。。。。

24.79 KB, 下载次数: 5

评分

1 查看全部评分

大太阳，心情好

回复

TA的精华主题

TA的得分主题

发表于 2020-2-17 09:04 | 显示全部楼层

[广告] ★ ChatOffice，能听会写的AI办公，包含百种Excel、Word、PPT工具，兼容WPS，百倍效率！★

Sub test()
Dim r%, i%
Dim arr, brr
With Worksheets("sheet1")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:ag" & r)
ReDim brr(1 To 10000, 1 To 4)
m = 0
For i = 2 To UBound(arr)
For j = 3 To UBound(arr, 2)
If Len(arr(i, j)) <> 0 Then
xm = Split(arr(i, j), " ")
For k = 0 To UBound(xm)
m = m + 1
brr(m, 1) = arr(i, 1)
brr(m, 3) = arr(i, 2)
brr(m, 4) = DateSerial(2019, 12, arr(1, j)) + CDate(xm(k))
Next
End If
Next
Next
End With
With Worksheets("sheet2")
.UsedRange.Offset(1, 0).Clear
.Range("a2").Resize(m, UBound(brr, 2)) = brr
End With
End Sub

复制代码

评分

1 查看全部评分

大太阳，心情好

回复

TA的精华主题

TA的得分主题

发表于 2020-2-17 09:08 | 显示全部楼层

[广告] ★ ChatOffice，能听会写的AI办公，包含百种Excel、Word、PPT工具，兼容WPS，百倍效率！★

详见附件。

24.16 KB, 下载次数: 7

回复

大太阳，心情好

TA的精华主题

TA的得分主题

楼主| 发表于 2020-2-17 17:14 | 显示全部楼层

[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★使用手册★

liulang0808 发表于 2020-2-17 08:11
附件内容供参考。。。。。。

您好，我发现数据多了就错误了，麻烦您再帮忙修改下，压缩包我从新上传了，谢谢微信截图_20200217170420.png

微信截图_20200217170420.png

微信截图_20200217170432.png

138.62 KB, 下载次数: 6

回复

TA的精华主题

TA的得分主题

发表于 2020-2-17 17:24 | 显示全部楼层

[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★免费下载 ★ ★ 使用帮助★

试试这个----

47.02 KB, 下载次数: 3

评分

1 查看全部评分

大太阳，心情好

回复

TA的精华主题

TA的得分主题

发表于 2020-2-17 17:32 | 显示全部楼层

[广告] ★会Excel,就能做支持PC、手机、Web、App、Windows、安卓、IOS、Linux信息一体化的各种管理系统 ★

大太阳，心情好发表于 2020-2-17 17:14
您好，我发现数据多了就错误了，麻烦您再帮忙修改下，压缩包我从新上传了，谢谢

Sub 按钮2_Click()
Dim brr()
arr = Sheets(1).UsedRange
ReDim brr(1 To UBound(arr) * UBound(arr, 2) * 4, 1 To 4)
r = 0
str1 = Split(arr(1, 1), "考勤表")(0)
With CreateObject("vbscript.regexp")
.Global = True
.Pattern = "\d+:\d+"
For j = 3 To UBound(arr)
For i = 3 To 33
If Len(arr(j, i)) > 0 Then
For Each m In .Execute(arr(j, i))
r = r + 1
brr(r, 1) = arr(j, 1)
brr(r, 3) = arr(j, 2)
brr(r, 4) = CDate(str1 & arr(2, i) & "日") + CDate(m.Value)
Next m
End If
Next i
Next j
End With
Sheets(2).[a1].CurrentRegion.Offset(1).ClearContents
If r > 0 Then Sheets(2).[a2].Resize(r, 4) = brr
End Sub

复制代码

之前看楼主的每个人一天仅有两个时间，刚才看到达了四次，所有brr数组范围增加下把

评分

1 查看全部评分

大太阳，心情好

回复

大太阳，心情好

TA的精华主题

TA的得分主题

楼主| 发表于 2020-2-17 17:58 | 显示全部楼层

[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★使用手册★

zmj9151 发表于 2020-2-17 17:24
试试这个----

您好，我发现超过100行就又错误了，我又重新上传了表格，麻烦您再帮忙看下，谢谢。

模拟2.17(1).zip

183.01 KB, 下载次数: 4

回复

大太阳，心情好

TA的精华主题

TA的得分主题

楼主| 发表于 2020-2-17 17:59 | 显示全部楼层

[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★免费下载 ★ ★ 使用帮助★

liulang0808 发表于 2020-2-17 17:32
之前看楼主的每个人一天仅有两个时间，刚才看到达了四次，所有brr数组范围增加下把

您好，我不知道该怎么改下，实在不好意思，麻烦您了

点评

8楼的代码就是修改后的发表于 2020-2-17 18:16

回复

12 / 2 页下一页

发新帖

最新热点 /1

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-4-20 09:40 , Processed in 0.047265 second(s), 12 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号沪ICP备11019229号-2

本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！本站特聘法律顾问：李志群律师

快速回复 返回顶部 返回列表