如何在杂乱的数据表找到对应的数据

今日123

要求：从数据表中自动查找相应类别与年限并填充 填充到查询表。查询条件是根据查询表里的岗位津贴来查询的

shiruiqiang

上班前的几分钟，思路先来一个。
然后字典

loirol

z865593849

简单的字典

ykcbf1100

看上去简单，感觉并不简单。

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.12.23
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("数据表")
   
6.         r = .Cells(Rows.Count, 1).End(3).Row
   
7.         c = .UsedRange.Columns.Count
   
8.         arr = .[a1].Resize(r, c)
   
9.     End With
   
10.     For i = 2 To r
    
11.         If arr(i, 1) <> Empty And arr(i, 2) = Empty Then k = k + 1: d1(k) = i
    
12.     Next
    
13.     For k = 1 To d1.Count
    
14.         r1 = d1(k)
    
15.         If k = d1.Count Then r2 = r Else r2 = d1(k + 1) - 1
    
16.         st = arr(r1, 1)
    
17.         For i = r1 + 1 To r2
    
18.             For j = 2 To UBound(arr, 2)
    
19.                 s = arr(i, j)
    
20.                 If Not d.exists(s) Then
    
21.                     d(s) = Array(st & arr(i, 1), arr(1, j))
    
22.                 Else
    
23.                     t = d(s)
    
24.                     t(0) = t(0) & "|" & st & arr(i, 1)
    
25.                     t(1) = t(1) & "|" & arr(1, j)
    
26.                     d(s) = t
    
27.                 End If
    
28.             Next
    
29.         Next
    
30.     Next
    
31.     On Error Resume Next
    
32.     With Sheets("查询")
    
33.         .UsedRange.Offset(1, 1).ClearContents
    
34.         arr = .UsedRange.Value
    
35.         For i = 2 To UBound(arr)
    
36.             s = arr(i, 1)
    
37.             n = 1
    
38.             If d.exists(s) Then
    
39.                 t = d(s)
    
40.                 st1 = Split(t(0), "|")
    
41.                 st2 = Split(t(1), "|")
    
42.                 For x = 0 To UBound(st1)
    
43.                     n = n + 2
    
44.                     arr(i, n - 1) = st1(x)
    
45.                     arr(i, n) = st2(x)
    
46.                 Next
    
47.             End If
    
48.         Next
    
49.         .UsedRange.Value = arr
    
50.         .UsedRange.Borders.LineStyle = 1
    
51.     End With
    
52.     Application.ScreenUpdating = True
    
53.     MsgBox "OK！"
    
54. End Sub
    

复制代码

loirol

ykcbf1100 发表于 2024-12-23 08:35
看上去简单，感觉并不简单。

附件供参考。。。

套字典的思路还是很直线的

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("数据表")
   
7.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.         arr = .Range("a2:i" & r)
   
9.         For i = 2 To UBound(arr)
   
10.             If Len(arr(i, 2)) = 0 Then
    
11.                 lb = arr(i, 1)
    
12.             Else
    
13.                 For j = 2 To UBound(arr, 2)
    
14.                     If Len(arr(i, j)) <> 0 Then
    
15.                         If Not d.exists(arr(i, j)) Then
    
16.                             ReDim brr(1 To 9)
    
17.                             brr(1) = 2
    
18.                         Else
    
19.                             brr = d(arr(i, j))
    
20.                         End If
    
21.                         brr(brr(1)) = lb & arr(i, 1)
    
22.                         brr(brr(1) + 1) = arr(1, j)
    
23.                         brr(1) = brr(1) + 2
    
24.                         d(arr(i, j)) = brr
    
25.                     End If
    
26.                 Next
    
27.             End If
    
28.         Next
    
29.     End With
    
30.     ReDim crr(1 To d.Count, 1 To 9)
    
31.     m = 0
    
32.     For Each aa In d.keys
    
33.         m = m + 1
    
34.         brr = d(aa)
    
35.         brr(1) = aa
    
36.         For j = 1 To UBound(brr)
    
37.             crr(m, j) = brr(j)
    
38.         Next
    
39.     Next
    
40.     With Worksheets("查询")
    
41.         With .Range("a3").Resize(UBound(crr), UBound(crr, 2))
    
42.             .Value = crr
    
43.             .Borders.LineStyle = xlContinuous
    
44.         End With
    
45.         .Range("a3").Resize(UBound(crr), UBound(crr, 2)).Sort key1:=.Range("a3"), order1:=xlAscending, Header:=xlNo
    
46.         With .UsedRange
    
47.             .HorizontalAlignment = xlCenter
    
48.             .VerticalAlignment = xlCenter
    
49.         End With
    
50.     End With
    
51. End Sub
    

复制代码

ykcbf1100

loirol 发表于 2024-12-23 08:41
套字典的思路还是很直线的

你的思路不错。。。

chxw68

参与一下。