hnnyxzh

Dim d1 As New Dictionary

Private Sub CommandButton1_Click()
Dim i%
    For i = 0 To ListBox2.ListCount - 1
    X = ListBox2.List(i)
   
    y = Val(ListBox3.List(i))

Sheet17.Shapes(X).Fill.ForeColor.SchemeColor = Cells(aa(y), 3).Interior.ColorIndex + 7

    Next i
Sheet17.[b2] = TextBox1
ActiveSheet.Shapes("Picture 1").Select
    Selection.Formula = "样表!$A$6K$42"
End Sub

Private Sub ListBox1_Click()
Dim m As Long, i As Long, ar
        ListBox2.Clear
       ListBox3.Clear
       Set ar = d1(ListBox1.Text)
        dk = ar.keys
        dt = ar.Items
        For i = 0 To ar.Count - 1
        ListBox3.AddItem dt(i)
        ListBox2.AddItem dk(i)
        Next
        
     
End Sub

Private Sub UserForm_Initialize()
Dim n As Long, i As Long, arr
n = Sheet1.[A65536].End(xlUp).Row
arr = Sheet1.[a1].Resize(n, 59)
Application.ScreenUpdating = False
On Error Resume Next
For j = 2 To 6
For i = 2 To n
xx = arr(1, j) & ""
yy = arr(i, j) & ""
zz = arr(i, 1) & ""
If d1.Exists(xx) = False Then Set d1(xx) = New Dictionary
        d1(xx)(zz) = yy

Next
Next
userform1.ListBox1.List = d1.keys
Application.ScreenUpdating = True
End Sub

hnnyxzh

可惜没有注释

hnnyxzh

简单测试了一下，很好用

hnnyxzh

方法如下：
在样表中建立自己辖区的地图
就是一个一个建立（用绘图工具栏的多边形工具绘出）下级单位的图形，然后改名为数据表中相应下级单位的名称即可。不需要修改任何代码。