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列,将所有的/替换为-,然后叹号改一改