vba编写人事组织结构树形图

一、程序界面

1、查询，查询某员工的人事信息

2、添加，添加新的公司、部门、员工信息

3、修改，修改已存在节点的名称

4、删除，删除选中的节点，节点下如有子节点，应先删除子节点

5、导出，将人事组织结构信息以excel格式导出

二、vba程序代码

'一、窗体初始化

Private Sub UserForm_Initialize()

Dim arr, r As Integer, i As Integer

Dim c1, c2 'c1,c2分别用来存放项目名称和代码

Dim iNode As Node

arr = Sheets("sheet1").Range("A1").CurrentRegion

r = UBound(arr, 1)

Me.TreeView_人事组织结构树.ImageList = Me.ImageList_图标集  '获取图标

For i = 2 To r Step 1

    c1 = arr(i, 1)

    c2 = arr(i, 2)

    If VBA.Len(c2) = 1 Then  '是总公司

        Set iNode = Me.TreeView_人事组织结构树.Nodes.Add(, , "A" & c2, c1 & "(" & c2 & ")", 1)

    ElseIf VBA.Len(c2) = 3 Then '是分公司

        Set iNode = Me.TreeView_人事组织结构树.Nodes.Add("A" & VBA.Left(c2, 1), tvwChild, "A" & c2, c1 & "(" & c2 & ")", 2)

    ElseIf VBA.Len(c2) = 5 Then '是部门

        Set iNode = Me.TreeView_人事组织结构树.Nodes.Add("A" & VBA.Left(c2, 3), tvwChild, "A" & c2, c1 & "(" & c2 & ")", 3)

        iNode.EnsureVisible

    ElseIf VBA.Len(c2) = 8 Then '是员工

        Set iNode = Me.TreeView_人事组织结构树.Nodes.Add("A" & VBA.Left(c2, 5), tvwChild, "A" & c2, c1 & "(" & c2 & ")", 4)

    End If

Next i

Me.MultiPage_多页框架.Value = 0 '查询分页为默认页

Sheets("sheet1").Visible = True

Sheets("sheet1").Select

End Sub

'二、查询功能

Private Sub CommandButton_查询_Click()

Dim d As Object, iNode As Node, st As String

Set d = VBA.CreateObject("scripting.dictionary")

For Each iNode In Me.TreeView_人事组织结构树.Nodes  '创建字典，Node.key为关键值，Node.text为值

    d(VBA.Replace(iNode.Key, "A", "")) = VBA.Split(iNode.Text, "(")(0)

Next iNode

st = Me.TextBox_查询代码.Text

If d.exists(st) Then

   If VBA.Len(st) = 3 Then

        Me.TextBox_查询公司.Text = d(st)

   ElseIf VBA.Len(st) = 5 Then

        Me.TextBox_查询公司.Text = d(VBA.Left(st, 3))

        Me.TextBox_查询部门.Text = d(st)

   ElseIf VBA.Len(st) = 8 Then

        Me.TextBox_查询公司.Text = d(VBA.Left(st, 3))

        Me.TextBox_查询部门.Text = d(VBA.Left(st, 5))

        Me.TextBox_查询姓名.Text = d(st)

    End If

Else

    MsgBox "代码不存在"

    Exit Sub

End If

'展开查到的节点

For Each iNode In Me.TreeView_人事组织结构树.Nodes

    If iNode.Key = "A" & st Then

        iNode.EnsureVisible

        Exit For

    End If

Next iNode

End Sub

'三、添加功能

Private Sub CommandButton_添加_Click()

Dim d As Object, iNode As Node

Dim c1 As String, c2 As String, f As Integer, r As Integer, i As Integer

Dim sh As Worksheet, st

'创建字典，node.key为关键值，node.text为item

Set d = VBA.CreateObject("scripting.dictionary")

For Each iNode In Me.TreeView_人事组织结构树.Nodes

    d(VBA.Replace(iNode.Key, "A", "")) = ""

Next iNode

'判断此代码是否已存在

If d.exists(Me.TextBox_添加代码.Text) Then

    MsgBox "此代码已存在"

    Exit Sub

End If

'添加代码

If Me.TextBox_添加项目.Text <> "" Then

Else

    MsgBox "“项目”名称不能为空"

    Exit Sub

End If

If VBA.IsNumeric(Me.TextBox_添加代码.Text) And Me.TextBox_添加代码 <> "" Then

    c1 = Me.TextBox_添加项目.Text

    c2 = Me.TextBox_添加代码.Text

    f = VBA.Len(c2)

    If f = 1 Then '是总公司

        Set iNode = Me.TreeView_人事组织结构树.Nodes.Add(, , "A" & c2, c1 & "(" & c2 & ")", 1)

    ElseIf f = 3 Then '是分公司

        If d.exists(VBA.Left(c2, 1)) Then

            Set iNode = Me.TreeView_人事组织结构树.Nodes.Add("A" & VBA.Left(c2, 1), tvwChild, "A" & c2, c1 & "(" & c2 & ")", 2)

        Else

            MsgBox "其所属总公司不存在，请先添加总公司"

            Exit Sub

        End If

    ElseIf f = 5 Then '是部门

        If d.exists(VBA.Left(c2, 3)) Then

            Set iNode = Me.TreeView_人事组织结构树.Nodes.Add("A" & VBA.Left(c2, 3), tvwChild, "A" & c2, c1 & "(" & c2 & ")", 3)

        Else

            MsgBox "其所属分公司不存在，请先添加分公司"

            Exit Sub

        End If

    ElseIf f = 8 Then '是员工

        If d.exists(VBA.Left(c2, 5)) Then

            Set iNode = Me.TreeView_人事组织结构树.Nodes.Add("A" & VBA.Left(c2, 5), tvwChild, "A" & c2, c1 & "(" & c2 & ")", 4)

        Else

            MsgBox "其所属部门不存在，请先添加部门"

            Exit Sub

        End If

    Else

    End If

    iNode.EnsureVisible

Else

    MsgBox "代码格式错误，请输入正确格式的代码"

    Exit Sub

End If

'同步到excel中

Set sh = Sheets("sheet1")

r = sh.Range("A1").CurrentRegion.Rows.Count

If f = 1 Then '同步总公司

    i = r

    sh.Rows(i + 1).Insert

    sh.Cells(i + 1, 1) = c1

    sh.Cells(i + 1, 2) = c2 * 1

    sh.Cells(i + 1, 1).Resize(1, 2).Interior.Color = VBA.RGB(146, 208, 80)

End If

If f = 3 Then '同步分公司

    st = VBA.Left(c2, 1) & "*"

    i = sh.Range("B1").Resize(r, 1).Find(what:=st, lookat:=xlWhole, searchdirection:=xlPrevious).Row

    sh.Rows(i + 1).Insert

    sh.Cells(i + 1, 1) = c1

    sh.Cells(i + 1, 2) = c2 * 1

    sh.Cells(i + 1, 1).Resize(1, 2).Interior.Color = VBA.RGB(204, 255, 204)

End If

If f = 5 Then '同步部门

    st = VBA.Left(c2, 3) & "*"

    i = sh.Range("B1").Resize(r, 1).Find(what:=st, lookat:=xlWhole, searchdirection:=xlPrevious).Row

    sh.Rows(i + 1).Insert

    sh.Cells(i + 1, 1) = c1

    sh.Cells(i + 1, 2) = c2 * 1

    sh.Cells(i + 1, 1).Resize(1, 2).Interior.Color = VBA.RGB(255, 204, 103)

End If

If f = 8 Then '同步员工

    st = VBA.Left(c2, 5) & "*"

    i = sh.Range("B1").Resize(r, 1).Find(what:=st, lookat:=xlWhole, searchdirection:=xlPrevious).Row

    sh.Rows(i + 1).Insert

    sh.Cells(i + 1, 1) = c1

    sh.Cells(i + 1, 2) = c2 * 1

End If

MsgBox prompt:="添加成功！", Buttons:=vbOKOnly + vbInformation, Title:="提示"

End Sub

'四、修改功能

Private Sub CommandButton_修改_Click()

Dim iNode As Node

Dim r As Integer, sh As Worksheet, i As Integer

'修改项目名称

If Me.TextBox_修改项目.Text <> "" Then

    For Each iNode In Me.TreeView_人事组织结构树.Nodes

        If iNode.Key = "A" & Me.TextBox_修改代码.Text Then

            iNode.Text = Me.TextBox_修改项目.Text & "(" & Me.TextBox_修改代码.Text & ")"

            Exit For

        End If

    Next iNode

Else

    MsgBox "“项目”名称不能为空"

    Exit Sub

End If

'同步到Excel中

Set sh = Sheets("sheet1")

r = sh.Range("A1").CurrentRegion.Rows.Count

i = sh.Range("B1").Resize(r, 1).Find(what:=Me.TextBox_修改代码.Text, lookat:=xlWhole, searchdirection:=xlNext).Row

sh.Cells(i, 1) = Me.TextBox_修改项目.Text

MsgBox prompt:="修改成功！", Buttons:=vbOKOnly + vbInformation, Title:="提示"

End Sub

'五、删除功能

Private Sub CommandButton_删除_Click()

Dim iNode As Node, t As Integer, f As Integer

Dim i As Integer, arr() 'arr()用于存放excel中的代码列，此数组要用到match中，必须要带(),arr()是一维数组

Dim sh As Worksheet, r As Integer

Dim arr1, arr2 'arr1为一维数组，用于存放被checked的item的key值，arr2为一维数组，用来存放checked的项目的key值在excel中的行号

Dim st As String

'判断checked项是否包含子级，如果有终止程序

f = 0 '用于统计被选中项目个数

For Each iNode In Me.TreeView_人事组织结构树.Nodes

    If iNode.Checked = True Then

        If iNode.Children > 0 Then

            MsgBox Chr(34) & iNode.Text & Chr(34) & "包含子项目，请先删除其子项目"  'chr(34)为双引号

            iNode.Child.EnsureVisible

            Exit Sub

        Else

            f = f + 1

            If f = 1 Then

                ReDim arr1(1 To f)

            Else

                ReDim Preserve arr1(1 To f)

            End If

            arr1(f) = VBA.Replace(iNode.Key, "A", "")

        End If

     End If

Next iNode

'提示是否确定删除

t = MsgBox(prompt:="确定要删除吗？", Buttons:=vbOKCancel + vbExclamation, Title:="警告")

'如果放弃，则退出

If t = 2 Then

    Exit Sub

End If

'如果确认，继续执行删除

'如果f=0，说明没有item被checked

If f = 0 Then

    MsgBox "请先选中要删除的项目"

    Exit Sub

End If

'如果f不等于0，继续删除

For i = 1 To f Step 1

    For Each iNode In Me.TreeView_人事组织结构树.Nodes

        If iNode.Checked = True Then

            Me.TreeView_人事组织结构树.Nodes.Remove iNode.Index

            Exit For

        End If

    Next iNode

Next i

'同步到excel

Set sh = Sheets("sheet1")

r = sh.Range("B1").CurrentRegion.Rows.Count

arr() = sh.Range(sh.Cells(1, 2), sh.Cells(r, 2))

arr() = Application.WorksheetFunction.Transpose(arr()) '将arr（）转置为一维数组,下标从1开始

ReDim arr2(1 To f)

For i = 1 To f Step 1

    arr2(i) = Application.WorksheetFunction.Match(arr1(i) * 1, arr(), 0) 'arr()中存放的是数字，arr1(i)中存放的是字符，通过arr1(i)*1将字符转换为数字

Next i

st = "A" & VBA.Join(arr2, ",A")

sh.Range(st).EntireRow.Delete

MsgBox prompt:="删除成功！", Buttons:=vbOKOnly + vbInformation, Title:="提示"

End Sub

'六、导出功能

Private Sub CommandButton_导出_Click()

Dim dia As Object

Dim iPath

Dim f As Integer, iname '用于判断文件是否已存在，f初始值为0，不存在时f=1

Set dia = Application.FileDialog(msoFileDialogFolderPicker)

dia.Title = "请先择导出位置"

dia.InitialFileName = ThisWorkbook.Path & "\"  '设置默认初始位置

If dia.Show = 0 Then  '如果点击取消会返回0，否则返回-1

    Exit Sub

End If

iPath = dia.SelectedItems.Item(1)

'判断指定路径下是否已存在重名,并确定不重复名

f = 0

iname = iPath & "\" & VBA.Format(Date, "yyyymmdd") & "人事组织结构.xlsx"

If VBA.Len(VBA.Dir(iname)) = 0 Then

    f = 1

Else

    i = 0

    Do

        i = i + 1

        iname = iPath & "\" & VBA.Format(Date, "yyyymmdd") & "人事组织结构(" & i & ").xlsx"

        If VBA.Len(VBA.Dir(iname)) = 0 Then

            f = 1

        End If

    Loop Until f = 1

End If

If f = 1 Then

    ThisWorkbook.Sheets("sheet1").Copy

    ActiveWorkbook.SaveAs Filename:=iname

    ActiveWorkbook.Close

    ThisWorkbook.Sheets("sheet1").Select

End If

End Sub

‘七、其他窗体事件

Private Sub MultiPage_多页框架_Change()

Me.TextBox_查询代码 = ""

Me.TextBox_查询公司 = ""

Me.TextBox_查询部门 = ""

Me.TextBox_查询姓名 = ""

Me.TextBox_添加代码 = ""

Me.TextBox_添加项目 = ""

Me.TextBox_修改代码 = ""

Me.TextBox_修改项目 = ""

If Me.MultiPage_多页框架.Value = 3 Then

    Me.TreeView_人事组织结构树.CheckBoxes = True

Else

    Me.TreeView_人事组织结构树.CheckBoxes = False

End If

End Sub

Private Sub TextBox_查询代码_Change()

Me.TextBox_查询公司 = ""

Me.TextBox_查询部门 = ""

Me.TextBox_查询姓名 = ""

End Sub

Private Sub TreeView_人事组织结构树_NodeCheck(ByVal Node As MSComctlLib.Node)

Dim bl As Boolean, iNode As Node

'子级获得父级同样的checked

If Me.MultiPage_多页框架.Value = 3 Then

    bl = Node.Checked

    For Each iNode In Me.TreeView_人事组织结构树.Nodes

        If iNode.Key Like Node.Key & "*" Then

            iNode.Checked = bl

        End If

    Next iNode

End If

End Sub

Private Sub TreeView_人事组织结构树_NodeClick(ByVal Node As MSComctlLib.Node)

Dim f As Integer

Dim bl As Boolean

Dim iNode As Node

'点击节点查看信息

If Me.MultiPage_多页框架.Value = 0 Then

   '清空原数据

    Me.TextBox_查询代码 = ""

    Me.TextBox_查询公司 = ""

    Me.TextBox_查询部门 = ""

    Me.TextBox_查询姓名 = ""

    '显示节点信息

    f = VBA.Len(Node.Key) - 1

    If f = 1 Then    '是总公司

    ElseIf f = 3 Then  '是分公司

        Me.TextBox_查询代码.Text = VBA.Replace(Node.Key, "A", "")

        Me.TextBox_查询公司.Text = VBA.Split(Node.Text, "(")(0)

    ElseIf f = 5 Then '是部门

        Me.TextBox_查询代码.Text = VBA.Replace(Node.Key, "A", "")

        Me.TextBox_查询公司.Text = VBA.Split(Node.Parent.Text, "(")(0)

        Me.TextBox_查询部门.Text = VBA.Split(Node.Text, "(")(0)

    ElseIf f = 8 Then  '是员工

        Me.TextBox_查询代码.Text = VBA.Replace(Node.Key, "A", "")

        Me.TextBox_查询公司.Text = VBA.Split(Node.Parent.Parent.Text, "(")(0)

        Me.TextBox_查询部门.Text = VBA.Split(Node.Parent.Text, "(")(0)

        Me.TextBox_查询姓名.Text = VBA.Split(Node.Text, "(")(0)

    End If

End If

'点击节点，显示要修改的节点信息

If Me.MultiPage_多页框架.Value = 2 Then

    Me.TextBox_修改代码.Text = VBA.Replace(Node.Key, "A", "")

    Me.TextBox_修改项目.Text = VBA.Split(Node.Text, "(")(0)

End If

'点击时，激活复选框

If Me.MultiPage_多页框架.Value = 3 Then

    If Node.Checked = False Then

        bl = True

    Else

        bl = False

    End If

    For Each iNode In Me.TreeView_人事组织结构树.Nodes

        If iNode.Key Like Node.Key & "*" Then

            iNode.Checked = bl

        End If

    Next iNode

End If

End Sub

三、源码软件下载

https://download.csdn.net/download/aaron19822007/85534671