VBA_打卡

Sub 开始执行()
MsgBox "此脚本时间执行过长，大约需要12分种左右，请耐心等待…………，在此脚本执行期间，电脑会出现卡顿"
Excel.Application.DisplayAlerts = False
    '变量wb代表一个工作表，将这个变量声明；
    Dim wb As Workbook
    '将打开的表赋值给wb这个变量
    Set wb = Workbooks.Open("c:data钉钉-打卡.xlsx")
    
	' 将表格内所有的星期*替换成空，这样会只留有时间，方便后续处理
    Cells.Replace What:="星期*", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
		
    ' 把D列当中带有次日的，全都再原行的下面再复制一行，原行结束等于空，被复制行的的结束时间等于上一行
    Sheets(1).Select
    For i = 5 To Range("a65536").End(xlUp).Row
     If Range("K" & i) Like "次*" Then
                Rows(i).Select
                Selection.Copy
                Selection.Insert Shift:=xlDown
                Range("K" & i) = Null
                Range("G" & i + 1) = Format(DateValue(Range("G" & i)) + 1)
				Range("I" & i + 1) = Null
        i = i + 1
    End If
    Next

    ' 取最后的打卡时间
    Columns("BH:BH").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove

        For i = 5 To Range("a65536").End(xlUp).Row
   
            If Sheets(1).Range("S" & i) <> "" Then
                Sheets(1).Range("BH" & i) = Sheets(1).Range("S" & i)
            ElseIf Sheets(1).Range("O" & i) <> "" Then
                Sheets(1).Range("BH" & i) = Sheets(1).Range("O" & i)
            Else
                Sheets(1).Range("BH" & i) = Sheets(1).Range("K" & i)
            End If
            
        Next
        
        
    ' 删除无用的行和列
    Set te = wb.Worksheets(1)
    te.Columns("L:BG").Delete Shift:=xlToLeft
'    te.Range("L:BG").Delete Shift:=xlToLeft
    Set te = wb.Worksheets(1)
    te.Columns("J").Delete Shift:=xlToLeft
    Set te = wb.Worksheets(1)
    te.Columns("H").Delete Shift:=xlToLeft
    Set te = wb.Worksheets(1)
    te.Columns("E").Delete Shift:=xlToLeft
    Set te = wb.Worksheets(1)
    te.Columns("A:C").Delete Shift:=xlToLeft
    Set te = wb.Worksheets(1)
    'te.Rows("1:2").Delete Shift:=xlUp
    te.Range("1:2").Delete Shift:=xlUp
    Set te = wb.Worksheets(1)
    te.Columns("B").Delete Shift:=xlToLeft
    
	' 所有的行都再复制一行
	Dim a As Integer
	For a = 4 To 25000 Step 2
		wb.Sheets(1).Rows(a).Select
		Selection.Copy
		Selection.Insert Shift:=xlDown
	Next
    
    '保存表格，如果没有这一步的话，前面的操作不会保存；
    ActiveWorkbook.Save
    '关闭表格
    wb.Close

	' 自动删除第四行
    Rows(4).Select
    Selection.EntireRow.Delete
	
	' 复制整理好的数据
    Set wb = Workbooks.Open("c:data钉钉-打卡.xlsx")
    wb.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    wb.Close
	
	' 按奇数和偶数进行取值，如果是偶数就取
Sheets(1).Select
For i = 3 To Sheets(2).Range("a65536").End(xlUp).Row
    Sheets(1).Range("a" & i + 1) = Sheets(2).Range("a" & i)
    Sheets(1).Range("b" & i + 1) = Split(Sheets(2).Range("b" & i), " ")(0)
    If i Mod 2 = 0 Then
        Sheets(1).Range("c" & i + 1) = Sheets(2).Range("c" & i)
    Else
        Sheets(1).Range("c" & i + 1) = Sheets(2).Range("E" & i)
    End If
Next


’ 将C列为空的行全部删除
Sheets(1).Select
    For i = Sheets(1).Range("a65536").End(xlUp).Row To 3 Step -1
        If Sheets(1).Range("c" & i) = "" Then
            Range("c" & i).Select
            Selection.EntireRow.Delete
        End If
    Next
' 把次日也全部替换为空
    Cells.Replace What:="次日", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Sheets(2).Delete
Excel.Application.DisplayAlerts = True

    q = Sheets(1).Range("a65536").End(xlUp).Row
    For i = 4 To q
    k = Len(Range("a" & i).Value)
    If k > 10 or k < 2 Then 
    Rows(i).Select
        With Selection.Interior
            .PatternColorIndex = xlAutomatic
            .Color = 65535
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
    End If
Next
MsgBox ("步执行完成！" & Chr(13) & "第一、请重点关注开头的两行，开头第一行很可能会少一行，如果少一行，请手动添加，请关注最后一行，对原表对应，看是否少行" & Chr(13) & "第二、注意标黄的和行，标黄的行是工号异常" & Chr(13) & "第三、请更改第二列和和第三列的格式，第二列yyyy-mm-dd分列，第三列空格和hh:mm")
End Sub

c列的处理，选中C列，将所有的空格替换成空，然后将格式改为hh:mm
b列的处理，选中b列，将所有的/替换为-，然后叹号改一改