如何根据第一张表中每个岗位对应的部室和岗级自动填写到第二张表中

251958279

如何根据第一张表中每个岗位对应的部室和岗级自动填写到第二张表中

gpk

oledb创建表，方法见吴版帖子：

各Excel版本使用SQL创建数据透视表的步骤教程

sql 语句：

1. TRANSFORM first(岗位名称) select 岗级,岗级1 from [1、【全部岗位】岗位等级序列表 $b2:f] where 岗级1 is not  null group by 岗级,岗级1 order by 岗级1 desc pivot 部室

复制代码

格式什么的自己调整吧，
附件：


岗位自动划分.rar (13.51 KB, 下载次数: 13)

2014-11-13 17:33 上传

点击文件名下载附件

chxw68

1. Sub test()
   
2.   Dim d As New Dictionary
   
3.   Dim d1 As New Dictionary
   
4.   Dim r%, i%, c%, j%
   
5.   Dim arr, brr()
   
6.   With Worksheets("1、【全部岗位】岗位等级序列表")
   
7.     r = .Cells(.Rows.Count, 2).End(xlUp).Row
   
8.     arr = .Range("d3:f" & r)
   
9.   End With
   
10.   n = 1
    
11.   For i = 1 To UBound(arr)
    
12.     If Not d1.Exists(arr(i, 1)) Then
    
13.       n = n + 1
    
14.       d1(arr(i, 1)) = n
    
15.     End If
    
16.     If Not d.Exists(arr(i, 2)) Then
    
17.       Set d(arr(i, 2)) = CreateObject("scripting.dictionary")
    
18.     End If
    
19.     If Not d(arr(i, 2)).Exists(arr(i, 1)) Then
    
20.       m = 1
    
21.       ReDim brr(1 To m)
    
22.     Else
    
23.       brr = d(arr(i, 2))(arr(i, 1))
    
24.       m = UBound(brr) + 1
    
25.       ReDim Preserve brr(1 To m)
    
26.     End If
    
27.     brr(m) = Mid(arr(i, 3), InStr(arr(i, 3), "】") + 1)
    
28.     d(arr(i, 2))(arr(i, 1)) = brr
    
29.   Next
    
30.   With Worksheets("sheet1")
    
31.     .Cells.Clear
    
32.     .Range("b1").Resize(1, d1.Count) = d1.Keys
    
33.     .Range("a1") = "岗级"
    
34.     c = .Cells(1, .Columns.Count).End(xlToLeft).Column
    
35.     For Each aa In d.Keys
    
36.       r0 = .UsedRange.Find(what:="*", lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
    
37.       For Each bb In d(aa).Keys
    
38.         brr = d(aa)(bb)
    
39.         .Cells(r0, d1(bb)).Resize(UBound(brr), 1) = Application.Transpose(brr)
    
40.       Next
    
41.       r1 = .UsedRange.Find(what:="*", lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
    
42.       With .Cells(r0, 1)
    
43.         .Value = aa
    
44.         .Resize(r1 - r0).Merge
    
45.       End With
    
46.       For j = 2 To c
    
47.         r2 = .Cells(.Rows.Count, j).End(xlUp).Row
    
48.         If r2 <= r0 Then
    
49.           .Cells(r0, j).Resize(r1 - r0).Merge
    
50.         End If
    
51.       Next
    
52.     Next
    
53.     r = .UsedRange.Find(what:="*", lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    
54.     With .Range("a1").Resize(r, c)
    
55.       .Borders.LineStyle = xlContinuous
    
56.       .HorizontalAlignment = xlCenter
    
57.       .VerticalAlignment = xlCenter
    
58.     End With
    
59.   End With
    
60. End Sub
    

复制代码

chxw68

详见附件。

251958279

3楼的是正确的，2楼的会丢失一些岗位，假设在符合两个条件下有多个岗位，则只会显示一个岗位。
非常感谢大家的帮忙

251958279

chxw68 发表于 2014-11-13 20:25
详见附件。

非常感谢，对我们太有用了

LMY123

TRANSFORM与字典