VBA 数据拆分和数据标记

对源数据按照人事组织编码进行拆分，生成独立工作簿,添加提示信息

一、新建模块，定义变量

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为工作簿名称