对源数据按照人事组织编码进行拆分,生成独立工作簿,添加提示信息
一、新建模块,定义变量
Sub workbooksSplit()
Dim fd As FileDialog
Dim vsi
Dim SheetFullName
Dim filePath
Dim totalRow_source
Dim companyList_Dic
Dim x
Dim totalRow_com
Dim companyName
Dim tm
Dim dt
Dim sheet_num
Dim starttime
Dim newFolder_Path
Dim totalRow_source_detail
二、基础准备
On Error Resume Next '忽略错误
Application.DisplayAlerts = False
'Application.ScreenUpdating = False '屏蔽弹框警告
newFolder_Path = ThisWorkbook.Sheets("首页").Range("A2").Value '获取文件路径
'先进行预处理,否则退出程序
If (newFolder_Path = "") And (ThisWorkbook.Sheets("首页").Range("A1").Value = "") Then
MsgBox "请先进行单据采集数据预处理!", Title:="温馨提示"
Exit Sub
End If
'获取日期时间
tm = Format(Time, "hhmmss")
dt = Format(Date, "yymmdd")
三、弹出文件对话框,选择需要处理的文件
Set fd = Application.FileDialog(msoFileDialogFilePicker) '允许用户选择文件
With fd
.Filters.Clear '清除现有文件类型
.Title = "请选择原始采集数据"
.Filters.Add "Excel文件", "*.xls;*.xlsx" '添加文件格式
.AllowMultiSelect = True '允许选择多个文件
.InitialFileName = ThisWorkbook.Path '默认打开工具表格所在文件夹
If .Show = -1 Then '显示窗体,且选择文件
starttime = Timer
For Each vsi In .SelectedItems '遍历选择的文件
SheetFullName = Mid(vsi, InStrRev(vsi, "\") + 1, 100) '提取文件名(含扩展名)
Workbooks.Open Filename:=vsi, ReadOnly:=True, UpdateLinks:=1
Workbooks(SheetFullName).Activate
totalRow_source = Sheets("Sheet1").Range("A1").End(xlDown).Row '源数据总行数
四、生成字典:对源数据人事组织编码去重
Set companyList_Dic = CreateObject("scripting.dictionary") '创建字典
For x = 2 To totalRow_source
companyList_Dic(Range("Y" & x).Value) = ""
Next x
'***获取PA代码对应的公司名称,更新字典Items为公司名称
ThisWorkbook.Sheets("PA公司名称").Activate
totalRow_com = Sheets("PA公司名称").Range("A1").End(xlDown).Row
For x = 2 To totalRow_com
For Each companyName In companyList_Dic.keys
If Sheets("PA公司名称").Range("A" & x) = companyName Then
companyList_Dic(companyName) = Sheets("PA公司名称").Range("B" & x)
End If
Next
Next x
五、按公司拆分权限明细表,生成独立工作簿,更新字典Items为工作簿名称