Excel VBA一键整理工资表，并进行分类新建工作簿、加密

本代码一键完成工作，如下

1. 我每一次下发工资表时，总会有一些我做表时的辅助行或列不要下发，这时我要删除;
2. 有些内容要给谁不要给谁，要另存为新的工作簿;
3. 最后我要进行加密下发。

本代码用的知识点有：

1. VBA字典，用于查询
2. VBA新建工作簿并复制数据进去
3. if then语句，select case 语句
4. union方法

=========代码=======

Sub delsh() '

Dim arrA, arrB, col_a, col_b, row_a, d, i, Rng As Range, ifile As String

Set dic = CreateObject("scripting.dictionary")

Application.ScreenUpdating = False

dic("XXX") = ""

arrA = Array("在职明细", "在职补发", "退休明细", "退休补发") ''''''设定要保留的工作表

col_a = "AA" ''''''''''设定要删除的，我的工作时的辅助列

row_a = 2308

col_b = "L" '''''''''设定要删除的，我的工作时的辅助列

For Each sh In Sheets

Select Case sh.Name

Case arrA(0) ''''''''在职明细

'MsgBox arr(0)

sh.Columns(col_a & ":" & col_a).Resize(, 10).Delete Shift:=xlToLeft

arrB = sh.Range("B1:B" & row_a).Value

For i = 5 To UBound(arrB)

If dic.exists(arrB(i, 1)) Then

If Rng Is Nothing Then

Set Rng = sh.Range("a" & i).Resize(1, 30)

Else

Set Rng = Union(Rng, sh.Range("a" & i).Resize(1, 30))

End If

End If

Next i

' Rng.Delete

Case arrA(1) '''''''''在职补发

'MsgBox arr(1)

sh.Columns(col_a & ":" & col_a).Resize(, 10).Delete Shift:=xlToLeft

Case arrA(2) '''''''''退休明细

'MsgBox arr(2)

sh.Columns(col_b & ":" & col_b).Resize(, 10).Delete Shift:=xlToLeft

Case arrA(3) ''''''''''退休补发

'MsgBox arr(3)

'Case arrA(4)

Case Else

'MsgBox "删除"

' Application.DisplayAlerts = False

'sh.Delete

'Application.DisplayAlerts = True

End Select

Next

ifile = ThisWorkbook.Path & "\" & "XXX.xls"

Workbooks.Add

Rng.Copy ActiveWorkbook.Sheets(1).Range("a5")

ActiveWorkbook.SaveAs ifile, True

ActiveWorkbook.Close True

Rng.Delete

' Path = ActiveWorkbook.Path

' ActiveWorkbook.SaveAs Filename:=Path & "\加密下发" & ThisWorkbook.Name

' ActiveWorkbook.Password = "123"

'ActiveWorkbook.Save

Application.ScreenUpdating = True

End Sub

=========THE END===========

本代码用于自己保存