VBA_出差

目录

• 出差
  • 原版
  • 改进版

出差

原版

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:dataVBA合并.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