VBA测试
钉钉转金蝶
请假单
需求
- 自动取值
- 筛选出未通过，被拒绝的
- 自动识别跨天并展开
代码
Sub 请假_第一步自动处理并自动取值 ()
Excel.Application.DisplayAlerts = False
'变量wb代表一个工作表，将这个变量声明；
Dim wb As Workbook
'将打开的表赋值给wb这个变量
Set wb = Workbooks.Open("c:\data\钉钉-请假.xlsx")
'将当前活动表格当中不需要的列全部删除；
Range("A:A,B:B,C:C,D:D,E:E,F:F,G:G,I:I,K:K,M:M,l:l,N:N,R:R,S:S,T:T").Select
Range("T1").Activate
Selection.Delete Shift:=xlToLeft
'保存表格，如果没有这一步的话，前面的操作不会保存；
ActiveWorkbook.Save
'关闭表格
wb.Close
' 恢复提醒
Excel.Application.DisplayAlerts = True
Dim str As String
'将上述处理好的表格复制到当前工作薄里面，在这里面会当做是sheet2
For i = 1 To 350
Set wb = Workbooks.Open("c:\data\钉钉-请假.xlsx")
wb.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
wb.Close
If str = "" Then
Exit For
End If
' 删除sheet2表格只留下sheet1表格
Next
Sheets(2).Select
Range("a2:e190").Copy Sheets(1).Range("a4")
Excel.Application.DisplayAlerts = False
Sheets(2).Delete
Excel.Application.DisplayAlerts = True
End Sub
Sub 请假_第二步自动展开 ()
Dim i, j, k
Dim strStart, strEnd
k = 300
For i = 4 To 195
For j = 1 To DateValue(Range("e" & i)) - DateValue(Range("d" & i)) + 1
If j = 1 Then
strStart = Split(Range("d" & i), " ")(1)
Else
strStart = "08:30"
End If
If j = DateValue(Range("e" & i)) - DateValue(Range("d" & i)) + 1 Then
strEnd = Split(Range("e" & i), " ")(1)
Else
strEnd = "17:30"
End If
Range("a" & i & ":c" & i).Copy Range("a" & k)
Range("d" & k) = Format(DateValue(Range("d" & i)) + j - 1, "yyyy-mm-dd ") & strStart
Range("e" & k) = Format(DateValue(Range("d" & i)) + j - 1, "yyyy-mm-dd ") & strEnd
k = k + 1
Next
Next
End Sub
sub 请假_第三步删除辅助数据 ()
Excel.Application.DisplayAlerts = False
Rows("4:299").Select
Selection.Delete Shift:=xlUp
Excel.Application.DisplayAlerts = True
end sub
使用步骤
- 将钉钉请假的工作簿放置到C盘的data文件夹，如果没有data文件夹就新建一个，文件必须命名为“钉钉-请假”（注意，没有双引号）
- 进入金蝶的模板表，在excel的的功能区当中依次点击“开发工具—-visual basic”—插入—-模块
- 在空白区域粘贴代码，然后关闭对话框即可；
加班单
代码
Sub 第一步_整理数据删除()
Excel.Application.DisplayAlerts = False
'变量wb代表一个工作表，将这个变量声明；
Dim wb As Workbook
'将打开的表赋值给wb这个变量
Set wb = Workbooks.Open("c:\data\钉钉-加班.xlsx")
'将当前活动表格当中不需要的列全部删除；
Range("A:A,B:B,C:C,D:D,E:E,F:F,G:G,I:I,K:K").Select
Range("K1").Activate
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 10
Range("A:A,B:B,C:C,D:D,E:E,F:F,G:G,I:I,K:K,L:L,M:M,N:N").Select
Range("N1").Activate
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 7
ActiveWindow.ScrollColumn = 8
ActiveWindow.ScrollColumn = 9
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 13
Range("A:A,B:B,C:C,D:D,E:E,F:F,G:G,I:I,K:K,L:L,M:M,N:N,O:O,R:R,S:S,T:T").Select
Range("T1").Activate
ActiveWindow.ScrollColumn = 14
Range("A:A,B:B,C:C,D:D,E:E,F:F,G:G,I:I,K:K,L:L,M:M,N:N,O:O,R:R,S:S,T:T,V:V,W:W" _
).Select
Range("W1").Activate
Selection.Delete Shift:=xlToLeft
ActiveWorkbook.Save
'关闭表格
wb.Close
' 恢复提醒
Excel.Application.DisplayAlerts = True
End Sub
Sub 第二步_复制整理好数据()
Dim str As String
'将上述处理好的表格复制到当前工作薄里面，在这里面会当做是sheet2
For i = 1 To 350
Set wb = Workbooks.Open("c:\data\钉钉-加班.xlsx")
wb.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
wb.Close
If str = "" Then
Exit For
End If
Next
End Sub
Sub 第三步_取值()
Dim a As Integer
For i = 2 To 500
Sheets(1).Range("a" & i + 2) = Sheets(2).Range("a" & i)
Sheets(1).Range("b" & i + 2) = Sheets(2).Range("b" & i)
Sheets(1).Range("d" & i + 2) = Sheets(2).Range("c" & i)
Sheets(1).Range("e" & i + 2) = Sheets(2).Range("d" & i)
Sheets(1).Range("f" & i + 2) = Sheets(2).Range("e" & i)
Next
End Sub
Sub 第四步_取年月日并删除辅助数据()
Sheets(1).Select
On Error Resume Next
For i = 4 To Sheet1.Range("a65536").End(xlUp).Row
Sheet1.Range("c" & i) = Split(Sheet1.Range("d" & i), " ")(0)
Next
Excel.Application.DisplayAlerts = False
Sheets(2).Delete
Excel.Application.DisplayAlerts = True
End Sub
打卡记录
思路
-
整数数据
- 遍历表格，将空白值的行一整行删除；
Sub 第一步_请假_删除周末两天以及删除无用的行和列() Excel.Application.DisplayAlerts = False '变量wb代表一个工作表，将这个变量声明； Dim wb As Workbook '将打开的表赋值给wb这个变量 Set wb = Workbooks.Open("c:\data\钉钉_打卡.xlsx") For i = 9000 To 1 Step -1 If Range("G" & i) Like "*星期六*" Then Range("G" & i).Select Selection.EntireRow.Delete ElseIf Range("G" & i) Like "*星期日*" Then Range("G" & i).Select Selection.EntireRow.Delete 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 '保存表格，如果没有这一步的话，前面的操作不会保存； ActiveWorkbook.Save '关闭表格 wb.Close ' 恢复提醒 Excel.Application.DisplayAlerts = True End Sub -
复制
- 将处理后的表格复制到目标工作薄
- 复制每一行
Sub 宏1() Dim a As Integer For a = 4 To 6000 Step 2 Rows(a).Select Selection.Copy Selection.Insert Shift:=xlDown Next End Sub -
取值
Sub shishi() For i = 2 To 100 Sheets(1).Range("a" & i) = Sheets(2).Range("a" & i) Sheets(1).Range("b" & i) = Split(Sheets(2).Range("d" & i), " ")(0) If i Mod 2 = 0 Then Sheets(1).Range("c" & i) = Sheets(2).Range("d" & i) Else Sheets(1).Range("c" & i) = Sheets(2).Range("c" & i) End If Next End Sub -
清除痕迹
将sheets(2)删除；
代码
Sub 第一步_请假_删除周末两天以及删除无用的行和列()
Excel.Application.DisplayAlerts = False
'变量wb代表一个工作表，将这个变量声明；
Dim wb As Workbook
'将打开的表赋值给wb这个变量
Set wb = Workbooks.Open("c:\data\钉钉_打卡.xlsx")
For i = 9000 To 1 Step -1
If Range("G" & i) Like "*星期六*" Then
Range("G" & i).Select
Selection.EntireRow.Delete
ElseIf Range("G" & i) Like "*星期日*" Then
Range("G" & i).Select
Selection.EntireRow.Delete
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 Range("a65536").End(xlUp).Row Step 2
wb.sheets(1).Rows(a).Select
Selection.Copy
Selection.Insert Shift:=xlDown
Next
'保存表格，如果没有这一步的话，前面的操作不会保存；
ActiveWorkbook.Save
'关闭表格
wb.Close
' 恢复提醒
Excel.Application.DisplayAlerts = True
End Sub
Sub 第二步_复制整理好数据()
Dim str As String
'将上述处理好的表格复制到当前工作薄里面，在这里面会当做是sheet2
For i = 1 To 350
Set wb = Workbooks.Open("c:\data\钉钉_打卡.xlsx")
wb.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
wb.Close
If str = "" Then
Exit For
End If
Next
End Sub
Sub 三处理数据()
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("d" & i)
End If
Next
End Sub
Sub 四再处理一次()
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
End Sub
补卡
思路
- 数据整理
- 删除A、B、C、D、E、F、G、I、K、L、M、N、O、（确认审批和审批中都要）
- 将数据复制
- 取值
代码
Sub 第一步_请假_删除周末两天以及删除无用的行和列()
Excel.Application.DisplayAlerts = False
'变量wb代表一个工作表，将这个变量声明；
Dim wb As Workbook
'将打开的表赋值给wb这个变量
Set wb = Workbooks.Open("c:\data\钉钉_补卡.xlsx")
Set te = wb.Worksheets(1)
te.Columns("R").Delete Shift:=xlToLeft
Set te = wb.Worksheets(1)
te.Columns("O:K").Delete Shift:=xlToLeft
Set te = wb.Worksheets(1)
te.Columns("A:G").Delete Shift:=xlToLeft
Set te = wb.Worksheets(1)
te.Columns("B").Delete Shift:=xlToLeft
'保存表格，如果没有这一步的话，前面的操作不会保存；
ActiveWorkbook.Save
'关闭表格
wb.Close
' 恢复提醒
Excel.Application.DisplayAlerts = True
End Sub
Sub 第二步_复制整理好数据()
Dim str As String
'将上述处理好的表格复制到当前工作薄里面，在这里面会当做是sheet2
For i = 1 To 350
Set wb = Workbooks.Open("c:\data\钉钉_补卡.xlsx")
wb.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
wb.Close
If str = "" Then
Exit For
End If
Next
End Sub
Sub 第三步_取值()
For i = 2 To Sheets(2).Range("a65536").End(xlUp).Row
Sheets(1).Range("a" & i + 2) = Sheets(2).Range("a" & i)
Sheets(1).Range("b" & i + 2) = Sheets(2).Range("b" & i)
Sheets(1).Range("c" & i + 2) = Split(Sheets(2).Range("c" & i), " ")(0)
Sheets(1).Range("d" & i + 2) = Split(Sheets(2).Range("c" & i), " ")(1)
Sheets(1).Range("e" & i + 2) = Sheets(2).Range("d" & i)
Next
Excel.Application.DisplayAlerts = False
Sheets(2).Delete
Excel.Application.DisplayAlerts = True
end sub
出差
代码
Sub 第一步_处理钉钉出差()
Excel.Application.DisplayAlerts = False
'变量wb代表一个工作表，将这个变量声明；
Dim wb As Workbook
'将打开的表赋值给wb这个变量
Set wb = Workbooks.Open("c:\data\钉钉_出差.xlsx")
Set te = wb.Worksheets(1)
te.Columns("A:D").Delete Shift:=xlToLeft
Set te = wb.Worksheets(1)
te.Columns("K:Z").Delete Shift:=xlToLeft
Set te = wb.Worksheets(1)
te.Columns("G:J").Delete Shift:=xlToLeft
Set te = wb.Worksheets(1)
te.Columns("C").Delete Shift:=xlToLeft
Set te = wb.Worksheets(1)
te.Columns("D").Delete Shift:=xlToLeft
'保存表格，如果没有这一步的话，前面的操作不会保存；
ActiveWorkbook.Save
'关闭表格
wb.Close
' 恢复提醒
Excel.Application.DisplayAlerts = True
End Sub
Sub 第二步_处理钉钉外出()
Excel.Application.DisplayAlerts = False
'变量wb代表一个工作表，将这个变量声明；
Dim wb As Workbook
'将打开的表赋值给wb这个变量
Set wb = Workbooks.Open("c:\data\钉钉_外出.xlsx")
Set te = wb.Worksheets(1)
te.Columns("A:D").Delete Shift:=xlToLeft
Set te = wb.Worksheets(1)
te.Columns("K:S").Delete Shift:=xlToLeft
Set te = wb.Worksheets(1)
te.Columns("G:J").Delete Shift:=xlToLeft
Set te = wb.Worksheets(1)
te.Columns("E").Delete Shift:=xlToLeft
Set te = wb.Worksheets(1)
te.Columns("C").Delete Shift:=xlToLeft
'保存表格，如果没有这一步的话，前面的操作不会保存；
ActiveWorkbook.Save
'关闭表格
wb.Close
' 恢复提醒
Excel.Application.DisplayAlerts = True
End Sub
Sub 开始合并()
Dim MyPath, MyName, AWbName
Dim Wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & "\" & "*.xls")
AWbName = ActiveWorkbook.Name
Num = 0
Do While MyName <> ""
If MyName <> AWbName Then
Set Wb = Workbooks.Open(MyPath & "\" & MyName)
Num = Num + 1
With Workbooks(1).ActiveSheet
.Cells(.Range("D1048576").End(xlUp).Row + 1, 1) = MyName
For G = 1 To Sheets.Count
.Cells(.Range("D1048576").End(xlUp).Row + 1, 2) = Wb.Sheets(G).Name
Wb.Sheets(G).UsedRange.Copy .Cells(.Range("D1048576").End(xlUp).Row + 1, 3)
Next
WbN = WbN & Chr(13) & Wb.Name
Wb.Close False
End With
End If
MyName = Dir
Loop
Range("B1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub
Sub 第二步_复制整理好数据()
Dim str As String
'将上述处理好的表格复制到当前工作薄里面，在这里面会当做是sheet2
For i = 1 To 350
Set wb = Workbooks.Open("c:\data\test\VBA合并.xlsx")
wb.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
wb.Close
If str = "" Then
Exit For
End If
Next
End Sub
Sub 取值()
For i = 2 To Sheets(2).Range("a65536").End(xlUp).Row
Sheets(1).Range("a" & i + 2) = Sheets(2).Range("d" & i)
Sheets(1).Range("b" & i + 2) = Sheets(2).Range("c" & i)
Sheets(1).Range("c" & i + 2) = Sheets(2).Range("a" & i)
Sheets(1).Range("d" & i + 2) = Sheets(2).Range("b" & i)
Next
End Sub
Next
Excel.Application.DisplayAlerts = False
Sheets(2).Delete
Excel.Application.DisplayAlerts = True
end sub
出差2
Sub 第一步_处理钉钉出差()
Excel.Application.DisplayAlerts = False
'变量wb代表一个工作表，将这个变量声明；
Dim wb As Workbook
'将打开的表赋值给wb这个变量
Set wb = Workbooks.Open("c:\data\钉钉_出差.xlsx")
Set te = wb.Worksheets(1)
te.Columns("A:G").Delete Shift:=xlToLeft
Set te = wb.Worksheets(1)
te.Columns("B").Delete Shift:=xlToLeft
Set te = wb.Worksheets(1)
te.Columns("C:L").Delete Shift:=xlToLeft
Set te = wb.Worksheets(1)
te.Columns("E:H").Delete Shift:=xlToLeft
'保存表格，如果没有这一步的话，前面的操作不会保存；
ActiveWorkbook.Save
'关闭表格
wb.Close
' 恢复提醒
Excel.Application.DisplayAlerts = True
End Sub
Sub 第二步_处理钉钉外出()
Excel.Application.DisplayAlerts = False
'变量wb代表一个工作表，将这个变量声明；
Dim wb As Workbook
'将打开的表赋值给wb这个变量
Set wb = Workbooks.Open("c:\data\钉钉_外出.xlsx")
Set te = wb.Worksheets(1)
te.Columns("A:G").Delete Shift:=xlToLeft
Set te = wb.Worksheets(1)
te.Columns("B").Delete Shift:=xlToLeft
Set te = wb.Worksheets(1)
te.Columns("C:F").Delete Shift:=xlToLeft
Set te = wb.Worksheets(1)
te.Columns("E:G").Delete Shift:=xlToLeft
'保存表格，如果没有这一步的话，前面的操作不会保存；
ActiveWorkbook.Save
'关闭表格
wb.Close
' 恢复提醒
Excel.Application.DisplayAlerts = True
End Sub
Sub 第二步_复制整理好数据()
Dim str As String
'将上述处理好的表格复制到当前工作薄里面，在这里面会当做是sheet2
For i = 1 To 350
Set wb = Workbooks.Open("c:\data\test\VBA合并.xlsx")
wb.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
wb.Close
If str = "" Then
Exit For
End If
Next
End Sub
Sub 取值()
For i = 2 To Sheets(2).Range("a65536").End(xlUp).Row
Sheets(1).Range("a" & i + 2) = Sheets(2).Range("b" & i + 1)
Sheets(1).Range("b" & i + 2) = Sheets(2).Range("a" & i + 1)
Sheets(1).Range("c" & i + 2) = Sheets(2).Range("c" & i + 1)
Sheets(1).Range("d" & i + 2) = Sheets(2).Range("d" & i + 1)
Next
Excel.Application.DisplayAlerts = False
Sheets(2).Delete
Excel.Application.DisplayAlerts = True
end sub
