出差
原版
Sub 出差_合并数据()
' 关闭闪屏和删除时的弹窗
Excel.Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim Wb As Workbook '变量wb代表一个工作表,将这个变量声明;
Set Wb = Workbooks.Open("c:\data\钉钉-出差.xlsx") '将打开的表赋值给wb这个变量
' 删除无用的列、将撤销和拒绝的行也删除
For i = 1 To Worksheets.Count
For L = Sheets(i).Range("a65536").End(xlUp).Row To 1 Step -1
If Range("C" & L) = "已撤销" Then
Range("C" & L).Select
Selection.EntireRow.Delete
End If
If Range("D" & L) = "拒绝" Then
Range("D" & L).Select
Selection.EntireRow.Delete
End If
Next
Set te = Sheets(i)
te.Columns("A:G").Delete Shift:=xlToLeft
Set te = Wb.Worksheets(i)
te.Columns("B").Delete Shift:=xlToLeft
Set te = Wb.Worksheets(i)
te.Columns("C:L").Delete Shift:=xlToLeft
Set te = Wb.Worksheets(i)
te.Columns("E:H").Delete Shift:=xlToLeft
Next
ActiveWorkbook.Save '保存表格,如果没有这一步的话,前面的操作不会保存;
Wb.Close '关闭表格
Set Wb = Workbooks.Open("c:\data\钉钉-外出.xlsx")
For i = 1 To Worksheets.Count
For L = Sheets(i).Range("a65536").End(xlUp).Row To 1 Step -1
If Range("C" & L) = "已撤销" Then
Range("C" & L).Select
Selection.EntireRow.Delete
End If
If Range("D" & L) = "拒绝" Then
Range("D" & L).Select
Selection.EntireRow.Delete
End If
Next
Set te = Sheets(i)
te.Columns("A:G").Delete Shift:=xlToLeft
Set te = Wb.Worksheets(i)
te.Columns("B").Delete Shift:=xlToLeft
Set te = Wb.Worksheets(i)
te.Columns("C:F").Delete Shift:=xlToLeft
Set te = Wb.Worksheets(i)
te.Columns("E:G").Delete Shift:=xlToLeft
Next
ActiveWorkbook.Save
Wb.Close
'合并数据
Dim MyPath, MyName, AWbName
Dim 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
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
Rows("1:1").Select
Selection.Delete Shift:=xlUp
'删除多余的表头
For L = 2 To Sheets(1).Range("a65536").End(xlUp).Row
If Range("a" & L) = "发起人工号" Then
Range("a" & L).Select
Selection.EntireRow.Delete
End If
Next
' 将异常的工号标黄
q = Sheets(1).Range("a65536").End(xlUp).Row
For i = 4 To 2
k = Len(Range("a" & i).Value)
If k > 10 Then
Rows(i).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next
Excel.Application.DisplayAlerts = True
Application.ScreenUpdating = True
'将已离职替换为空
Columns("B:B").Select
Selection.Replace What:="(已离职)", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
' 将异常的时间标黄
For i = 2 To Range("a65536").End(xlUp).Row
If Range("C" & i) Like "*午*" or Range("D" & i) Like "*午*" Then
Rows(i).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
endif
next
MsgBox "已经处理好出钉钉外出和钉钉出差 并将这两张表内容合并到了这一张表里面! & 已经将已经离职替换为空 & 标黄的是工号或时间格式不符合要求,请仔细核对之后保存退出!!"
End Sub
Sub 取值()
'把没用的行删除
Rows("4:9").Select
Selection.Delete Shift:=xlUp
' 取值
Set wb = Workbooks.Open("c:\data\VBA合并.xlsx")
wb.Sheets(1).Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
wb.Close
For i = 2 To Sheets(2).Range("a65536").End(xlUp).Row
Sheets(1).Range("a" & i + 2) = Sheets(2).Range("b" & i)
Sheets(1).Range("b" & i + 2) = Sheets(2).Range("a" & i)
Sheets(1).Range("c" & i + 2) = Sheets(2).Range("c" & i)
Sheets(1).Range("d" & i + 2) = Sheets(2).Range("d" & i)
Next
' 把辅助的数据删除
Excel.Application.DisplayAlerts = False
Sheets(2).Delete
Excel.Application.DisplayAlerts = True
Dim strStart, strEnd
k = 2000
For i = 4 To Range("a65535").End(xlUp).Row
For j = 1 To DateValue(Range("d" & i)) - DateValue(Range("c" & i)) + 1
If j = 1 Then
strStart = Split(Range("c" & i), " ")(1)
Else
strStart = "08:30"
End If
If j = DateValue(Range("d" & i)) - DateValue(Range("c" & i)) + 1 Then
strEnd = Split(Range("d" & i), " ")(1)
Else
strEnd = "17:30"
End If
Range("a" & i & ":b" & i).Copy Range("a" & k)
Range("c" & k) = Format(DateValue(Range("c" & i)) + j - 1, "yyyy-mm-dd ") & strStart
Range("d" & k) = Format(DateValue(Range("c" & i)) + j - 1, "yyyy-mm-dd ") & strEnd
k = k + 1
Next
Next
'出差_第三步删除辅助数据()
Excel.Application.DisplayAlerts = False
Rows("4:1999").Select
Selection.Delete Shift:=xlUp
Excel.Application.DisplayAlerts = True
MsgBox "处理完,请仔细核对!"
End Sub
改进版
Sub 出差_合并数据()
FILE_出差 = Application.GetOpenFilename
FILE_外出 = Application.GetOpenFilename
' 静默执行;
Application.ScreenUpdating = False
Excel.Application.DisplayAlerts = False
Dim Wb As Workbook '变量wb代表一个工作表,将这个变量声明;
Set Wb = Workbooks.Open(FILE_出差) '将打开的表赋值给wb这个变量
' 删除无用的列、将撤销和拒绝的行也删除
For i = 1 To Worksheets.Count
For L = Sheets(i).Range("a65536").End(xlUp).Row To 1 Step -1
If Range("C" & L) = "已撤销" Then
Range("C" & L).Select
Selection.EntireRow.Delete
End If
If Range("D" & L) = "拒绝" Then
Range("D" & L).Select
Selection.EntireRow.Delete
End If
Next
Set te = Sheets(i)
te.Columns("A:G").Delete Shift:=xlToLeft
Set te = Wb.Worksheets(i)
te.Columns("B").Delete Shift:=xlToLeft
Set te = Wb.Worksheets(i)
te.Columns("C:L").Delete Shift:=xlToLeft
Set te = Wb.Worksheets(i)
te.Columns("E:H").Delete Shift:=xlToLeft
Next
ActiveWorkbook.Save '保存表格,如果没有这一步的话,前面的操作不会保存;
Wb.Close '关闭表格
Set Wb = Workbooks.Open(FILE_外出)
For i = 1 To Worksheets.Count
For L = Sheets(i).Range("a65536").End(xlUp).Row To 1 Step -1
If Range("C" & L) = "已撤销" Then
Range("C" & L).Select
Selection.EntireRow.Delete
End If
If Range("D" & L) = "拒绝" Then
Range("D" & L).Select
Selection.EntireRow.Delete
End If
Next
Set te = Sheets(i)
te.Columns("A:G").Delete Shift:=xlToLeft
Set te = Wb.Worksheets(i)
te.Columns("B").Delete Shift:=xlToLeft
Set te = Wb.Worksheets(i)
te.Columns("C:F").Delete Shift:=xlToLeft
Set te = Wb.Worksheets(i)
te.Columns("E:G").Delete Shift:=xlToLeft
Next
ActiveWorkbook.Save
Wb.Close
'合并数据
Dim MyPath, MyName, AWbName
Dim 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
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
Rows("1:1").Select
Selection.Delete Shift:=xlUp
'删除多余的表头
For L = 2 To Sheets(1).Range("a65536").End(xlUp).Row
If Range("a" & L) = "发起人工号" Then
Range("a" & L).Select
Selection.EntireRow.Delete
End If
Next
' 将异常的工号标黄
q = Sheets(1).Range("a65536").End(xlUp).Row
For i = 4 To 2
k = Len(Range("a" & i).Value)
If k > 10 Then
Rows(i).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next
Excel.Application.DisplayAlerts = True
Application.ScreenUpdating = True
'将已离职替换为空
Columns("B:B").Select
Selection.Replace What:="(已离职)", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
' 将异常的时间标黄
For i = 2 To Range("a65536").End(xlUp).Row
If Range("C" & i) Like "*午*" Or Range("D" & i) Like "*午*" Then
Rows(i).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next
For i = 2 To Range("a65535").End(xlUp).Row
strstart = Split(Range("c" & i), " ")(1)
endtime = "17:30"
If strstart >= endtime Then
Rows(i).Select
With Selection.Interior
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End If
Next
MsgBox "已经处理好出钉钉外出和钉钉出差 并将这两张表内容合并到了这一张表里面! & 已经将已经离职替换为空 & 标黄的是工号或时间格式不符合要求,请仔细核对之后保存退出!!"
End Sub