计算时间

不知道为什么

风雨相随3 发表于 2018-9-8 20:26
Sub 出勤()
Dim Arr, Brr, i%, WT%, wD$, x%, y&
Set Dic = CreateObject("Scripting.Dictionary")

+ wD 改为

+wt

截图好像么截全，不好意思

风雨相随3

风雨相随3 发表于 2018-9-8 20:26
Sub 出勤()
Dim Arr, Brr, i%, WT%, wD$, x%, y&
Set Dic = CreateObject("Scripting.Dictionary")

Sub 出勤()
Dim Arr, Brr, i%, WT%, wD$, x%, y&
Set Dic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Arr = Sheets("出勤时间").[a1].CurrentRegion
ReDim Brr(1 To UBound(Arr), 1 To 100)

For i = 2 To UBound(Arr)
WT = Arr(i, 6) + Arr(i, 7) + Arr(i, 8) + Arr(i, 9)
wD = "第" & WorksheetFunction.WeekNum(Arr(i, 1)) & "周"
If Not Dic.exists(wD) Then
y = y + 1
Dic(wD) = y
Brr(1, y) = wD
End If
If Not Dic.exists(Arr(i, 2)) Then
x = x + 1

Dic(Arr(i, 2)) = x
Brr(x, 1) = Arr(i, 2): Brr(x, 2) = Arr(i, 3)
Brr(x, Dic(wD)) = WT


Else
Brr(Dic(Arr(i, 2)), Dic(wD)) = Brr(Dic(Arr(i, 2)), Dic(wD)) + WT
End If
Next i
Brr(1, 2) = "姓名"
Brr(1, 1) = "工号"
With Sheets("汇算")
Cells.ClearContents
.[a1].Resize(x, y) = Brr
End With
Set Dic = Nothing
Application.ScreenUpdating = True
End Sub改成Ｔ还是通过不了，因为“第”２８“周”＋８是加不了的。

不知道为什么

风雨相随3 发表于 2018-9-8 21:41
Sub 出勤()
Dim Arr, Brr, i%, WT%, wD$, x%, y&
Set Dic = CreateObject("Scripting.Dictionary")

把你出错的附件上传把

风雨相随3

不知道为什么 发表于 2018-9-8 21:44
把你出错的附件上传把

计算时间.rar (14.09 KB, 下载次数: 4)

2018-9-8 21:51 上传

点击文件名下载附件

不知2003版本能通用不？

不知道为什么

风雨相随3 发表于 2018-9-8 21:51
不知2003版本能通用不？

我没有03版本的，无法测试，应该可以通用。

你写的代码问题如下：

风雨相随3

现在可以了，曹试试2003版。

风雨相随3

不知道为什么 发表于 2018-9-8 22:00
我没有03版本的，无法测试，应该可以通用。

你写的代码问题如下：

Sub 出勤()
Dim Arr, Brr, i%, WT%, wD$, x%, y&
Set Dic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Arr = Sheets("出勤时间").[a1].CurrentRegion
ReDim Brr(1 To UBound(Arr), 1 To 100)
x = 1: y = 2
For i = 2 To UBound(Arr)
WT = Arr(i, 6) + Arr(i, 7) + Arr(i, 8) + Arr(i, 9)
wD = "第" & WorksheetFunction.WeekNum(Arr(i, 1)) & "周"
If Not Dic.exists(wD) Then
y = y + 1
Dic(wD) = y
Brr(1, y) = wD
End If
If Not Dic.exists(Arr(i, 2)) Then
x = x + 1

Dic(Arr(i, 2)) = x
Brr(x, 1) = Arr(i, 2): Brr(x, 2) = Arr(i, 3)
Brr(x, Dic(wD)) = WT


Else
Brr(Dic(Arr(i, 2)), Dic(wD)) = Brr(Dic(Arr(i, 2)), Dic(wD)) + WT
End If
Next i
Brr(1, 2) = "姓名"
Brr(1, 1) = "工号"
With Sheets("汇算")
.Cells.ClearContents
.[a1].Resize(x, y) = Brr
End With
Set Dic = Nothing
Application.ScreenUpdating = True
End Sub

2003版这句过不了，因为2003版没有WeekNum这个函数。

风雨相随3

不知道为什么 发表于 2018-9-8 22:00
我没有03版本的，无法测试，应该可以通用。

你写的代码问题如下：

计算时间2003.rar (15.32 KB, 下载次数: 2)

2018-9-9 06:06 上传

点击文件名下载附件

Sub 出勤()Dim Arr, Brr, i%, WT%, wD$, x%, y&, wDa&, wDe&, wdi&, wDee&
Set Dic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Arr = Sheets("出勤时间").[a1].CurrentRegion
ReDim Brr(1 To UBound(Arr), 1 To 100)
x = 1: y = 2
For i = 2 To UBound(Arr)
WT = Arr(i, 6) + Arr(i, 7) + Arr(i, 8) + Arr(i, 9)
wDa = Day(Arr(i, 1))
wDe = WorksheetFunction.Weekday(Arr(i, 1), 2)
wDee = WorksheetFunction.Weekday(Arr(i, 1) - wDa + 1, 2)
wdi = Int(((wDa - 1) / 7) + 1 + (wDee > wDe) * 1)
wD = "第" & wdi & "周"
'wD = "第" & WorksheetFunction.WeekNum(Arr(i, 1)) & "周"
If Not Dic.exists(wD) Then
y = y + 1
Dic(wD) = y
Brr(1, y) = wD
End If
If Not Dic.exists(Arr(i, 2)) Then
x = x + 1

Dic(Arr(i, 2)) = x
Brr(x, 1) = Arr(i, 2): Brr(x, 2) = Arr(i, 3)
Brr(x, Dic(wD)) = WT


Else
Brr(Dic(Arr(i, 2)), Dic(wD)) = Brr(Dic(Arr(i, 2)), Dic(wD)) + WT
End If
Next i
Brr(1, 2) = "姓名"
Brr(1, 1) = "工号"
With Sheets("汇算")
.Cells.ClearContents
.[a1].Resize(x, y) = Brr
End With
Set Dic = Nothing
Application.ScreenUpdating = True
End Sub

为适应excel2003我改了黄色部分代码，测试后生成“第1周”、“第0周”、“第2周”、“第3周”、“第4周”、“第5周”，而不是1-6周。请问我错在什么地方？

如果要写入Brr （1，3）=“部门”该改那些地方?

不知道为什么

风雨相随3 发表于 2018-9-9 06:12
Sub 出勤()Dim Arr, Brr, i%, WT%, wD$, x%, y&, wDa&, wDe&, wdi&, wDee&
Set Dic = CreateObject("Scr ...

你wdi的计算是不是搞复杂了？试试
wdi=wda\8+1
注意除号不要写错

风雨相随3

不知道为什么 发表于 2018-9-9 07:57
你wdi的计算是不是搞复杂了？试试
wdi=wda\8+1
注意除号不要写错

计算时间2003.zip (16.36 KB, 下载次数: 3)

2018-9-9 08:14 上传

点击文件名下载附件

那样只是按1-7号为一周，而不是以星期一为周的第一天。生成的只有四周。