为什么我Excel里面的VBA程序不自动计算考勤了，

李李大虫子 发表于 2024-4-8 09:00

本帖最后由李李大虫子于 2024-4-8 14:00 编辑

公司的一个大神写的代码，L4表格内没有数值的话就只计算第一行，L4填入数值的话就往下计算了
请问这是什么原因呢

链接：https://pan.baidu.com/s/1zJbpJyABsK4vlLt7mY1n3g
提取码：f6pv 密码 52pojie

谢谢{:301_1003:}

Public Sub DaoRu()

Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.AllowMultiSelect = False '多选择
fd.Filters.Clear '清除文件过滤器
'设置两个文件过滤器
fd.Filters.Add "Excel Files", "*.xls"
res = fd.Show
'FileDialog 对象的 Show 方法显示对话框，并且返回 -1（如果您按 OK）和 0（如果您按 Cancel）。
If fd.SelectedItems.Count = 0 Then
   Exit Sub
End If

Dim wb As Workbook
Dim sht As Worksheet

If Sheet1.AutoFilterMode = True Then
   Sheet1.AutoFilter.ShowAllData
End If
If Sheet2.AutoFilterMode = True Then
   Sheet2.AutoFilter.ShowAllData
End If
r = Sheet1.Cells(Rows.Count, "b").End(xlUp).Row
If r > 1 Then
   Sheet1.Range("b2:f" & r).ClearContents
End If
lj = fd.SelectedItems(1)
Set wb = Workbooks.Open(lj, False, 1)
Set sht = wb.Sheets(1)
tmpr = sht.UsedRange.Rows.Count
tmpr = sht.Cells(Rows.Count, "L").End(xlUp).Row + 2
mrr = getxmrr(sht, tmpr)

arr = sht.Range("d1:ah1")

brr = mrr(2)
h = mrr(1)
Set d = CreateObject("Scripting.Dictionary")
Set reg = CreateObject("VBSCRIPT.REGEXP")
ReDim scrr(1 To h * 31, 1 To 5)
' wb.Close
For i = 1 To 31
   rq = arr(1, i)
   For j = 1 To h
         js = js + 1
         tmpstr = brr(j, i + 1)
         tmpstr2 = ""
         If i < 31 Then
            tmpstr2 = brr(j, i + 1)
         End If
      ' If js = 25 Then Stop
         scrr(js, 1) = brr(j, 1)
      ' If scrr(js, 1) = "亓" Then Stop

         sjrr = getsj(tmpstr, tmpstr2, rq, d, reg)


         scrr(js, 2) = sjrr(1)
         scrr(js, 3) = sjrr(2)
         scrr(js, 4) = rq

         If sjrr(3) <> "" Then

            scrr(js, 5) = Format(sjrr(3), "0.00")
         End If


         VBA.DoEvents
   Next
Next

ReDim scrr2(1 To UBound(scrr), 1 To 5)
ct = 0
For i = 1 To UBound(scrr)
   sj1 = scrr(i, 2)
   sj2 = scrr(i, 3)
   If sj1 <> "" Or sj2 <> "" Then
         ct = ct + 1
         For j = 1 To 5
            scrr2(ct, j) = scrr(i, j)
         Next

   End If

Next

Sheet1.Range("b2").Resize(UBound(scrr), 5) = scrr2
MsgBox "导入成功!"
End Sub

'加班时间表转天数汇总表
Public Sub TianShuJiSuan()

If Sheet1.AutoFilterMode = True Then
   Sheet1.AutoFilter.ShowAllData
End If
If Sheet2.AutoFilterMode = True Then
   Sheet2.AutoFilter.ShowAllData
End If
r = Sheet2.UsedRange.Rows.Count
If r < 2 Then r = 2
Sheet2.Range("a2:e" & r).ClearContents

r1 = Sheet1.Cells(Rows.Count, "b").End(xlUp).Row
If r1 < 2 Then r1 = 2
Set d = CreateObject("Scripting.Dictionary")

arr = Sheet1.Range("b2:f" & r1)
ReDim scrr(1 To UBound(arr), 1 To 3)

For i = 1 To UBound(arr)
   tmpk = arr(i, 1)
   If tmpk <> "" Then


         If d.exists(tmpk) = False Then
            js = js + 1
            d(tmpk) = js

         End If
         h = d(tmpk)
         scrr(h, 1) = tmpk
         scrr(h, 2) = scrr(h, 2) + Val(arr(i, 5))
         scrr(h, 3) = Format(scrr(h, 2) / 7.5, "0.00")
   End If
Next
Sheet2.Activate

Sheet2.Range("a2").Resize(js, 3) = scrr
MsgBox "汇总完成"
End Sub

'时间差值计算
Private Function ChaZhiJiSuan(t1, t2)
s1 = VBA.TimeValue(t1 & ":00")
s2 = VBA.TimeValue(t2 & ":00")
If s2 < s1 Then
   s2 = s2 + 1
End If
jg = Format((s2 - s1) * 24, "0.00")
ChaZhiJiSuan = jg
End Function

'获取标准考勤数组

Private Function getxmrr(sht As Worksheet, tmpr)
ReDim scrr(1 To tmpr, 1 To 34)
For i = 3 To tmpr
   js = js + 1
   scrr(js, 1) = sht.Cells(i, "b")
   For c = 4 To Range("ah1").Column
         scrr(js, c - 2) = sht.Cells(i, c)

   Next

Next
ReDim jgrr(1 To 2)
jgrr(1) = js
jgrr(2) = scrr
getxmrr = jgrr
End Function

'获取单日上下班时间和差值
Private Function getsj(tmpstr, tmpstr2, rqstr, d, reg)
Dim scrr(1 To 3)

d.RemoveAll
riqi = VBA.CDate(rqstr)
yue = VBA.Month(riqi)
If yue >= 5 And yue <= 9 Then
   qdsj = VBA.TimeValue("17:30:00")
Else
   qdsj = VBA.TimeValue("17:00:00")
End If

yanshi = qdsj + VBA.TimeValue("00:30:00")

chaoshi = qdsj + VBA.TimeValue("02:00:00")

pstr = "\d{2}:\d{2}"

With reg
   .Global = True
   .IgnoreCase = True
   .Pattern = pstr
End With

Set mcs = reg.Execute(tmpstr)
sbsj = ""
For i = 0 To mcs.Count - 1
   s = mcs(i).Value
   t = VBA.TimeValue(s & ":00")
   If t >= qdsj Then
         If scrr(1) = "" Then
            sbsj = t
            scrr(1) = s
         End If
         d(s) = s
         xbsj = t

   End If
Next

If d.Count > 1 Then
   krr = d.keys()
   scrr(2) = krr(d.Count - 1)
End If

crpd = 0
Set mcs2 = reg.Execute(tmpstr2)
If mcs2.Count > 0 Then
   crxb = VBA.TimeValue(mcs2(0).Value & ":00")
   If crxb < VBA.TimeValue("06:00:00") Then
         crpd = 1
         xbsj = crxb
         scrr(2) = mcs2(0).Value
   End If
End If

If scrr(1) = "" Then
   scrr(2) = ""
End If
jiaban = ""

If scrr(1) <> "" And scrr(2) <> "" Then
   sbsj = VBA.TimeValue(scrr(1) & ":00")
   xbsj = VBA.TimeValue(scrr(2) & ":00")

   If xbsj > chaoshi And sbsj < yanshi Then
      sbsj = yanshi
      scrr(1) = VBA.Format(sbsj, "hh:mm")
   End If


   If crpd = 0 Then

      jiaban = (xbsj - sbsj) * 24



   End If


   If crpd = 1 Then
         jiaban = (1 + xbsj - sbsj) * 24

   End If


End If

scrr(3) = jiaban

getsj = scrr
End Function

wjbg2022 发表于 2024-4-8 10:06

你不上传excel文件，我们很难调试的喔！

stopf578 发表于 2024-4-8 10:15

上传个文件

李李大虫子 发表于 2024-4-8 10:21

已上传，不知道为啥评论里的回复回复不了呢

colinton07 发表于 2024-4-8 11:36

as614001 发表于 2024-4-8 11:48

orb001 发表于 2024-4-8 12:39

myFreedao 发表于 2024-4-8 13:20

帮你临时解决了一下。
Ⅰ、tmpr = sht.Cells(Rows.Count, "L").End(xlUp).Row + 2修改为tmpr = sht.Cells(Rows.Count, "L").End(xlUp).Row + 4；
Ⅱ、考勤记录表有数据后，在第二行往后面插入2行。#让数据从第4行开始。
Ⅲ、在L4单元格填入0.

可以正常跑通，你试一下

myFreedao 发表于 2024-4-8 13:23

myFreedao 发表于 2024-4-8 13:20
帮你临时解决了一下。
Ⅰ、tmpr = sht.Cells(Rows.Count, "L").End(xlUp).Row + 2修改为tmpr = sht.Cells( ...

我又测试了一遍是可以的

archon1 发表于 2024-4-8 13:56

文件分享已取消，测试不了。

页: [1] 2

吾爱破解 - 52pojie.cn's Archiver

为什么我Excel里面的VBA程序不自动计算考勤了，