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

李李大虫子

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

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

谢谢

[Visual Basic] 纯文本查看 复制代码

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

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

stopf578

上传个文件

李李大虫子

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

myFreedao

帮你临时解决了一下。
Ⅰ、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

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

我又测试了一遍是可以的