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

今日123

借用老师的代码 用一个取巧的方法写了一个
Sub 字典查询()
Dim arr, brr, i, j, crr, d As Object
Set d = CreateObject("Scripting.dictionary")
With Sheets("数据表")
    arr = .[a2].CurrentRegion
     For i = 2 To UBound(arr)
        If Right(arr(i, 1), 1) <> "级" And Right(arr(i, 1), 1) <> "工" Then
            temp = arr(i, 1)
        Else
            arr(i, 1) = temp & arr(i, 1)
        End If
        For j = 2 To UBound(arr, 2)
            If IsNumeric(arr(i, j)) And arr(i, j) > 0 Then
                d(arr(i, j)) = d.Item(arr(i, j)) & arr(i, 1) & "|" & arr(1, j) & "|"
            End If
        Next j
    Next i
End With
With Sheets("查询")
    brr = .[a2].CurrentRegion.Resize(, 20)
    r = 2
    For i = 2 To UBound(brr)
        If d.exists(brr(i, 1)) Then
            crr = Split(d.Item(brr(i, 1)), "|")
            For j = 0 To UBound(crr)
                brr(r, j + 2) = crr(j)
            Next j
        End If
        r = r + 1
    Next i
    .[a2].CurrentRegion.Resize(, 20) = brr
End With
End Sub

lkqsmxw

今日123 发表于 2024-12-23 09:26
正是我想要的结果谢谢老师

KKKKKKKKKKKKKKKKKKKKKKKKKKK

翁知江安

Sub tqu1()
Dim i, j, k, irow, icolumn, irow1, icolumn1, m, s, t, p
Dim ar, br, cr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
irow = Sheets("数据表").[a65536].End(xlUp).Row
icolumn = Sheets("数据表").[iv2].End(xlToLeft).Column
ar = Sheets("数据表").Range("a1:k" & irow)
ar(3, 11) = ar(3, 1): ar(3, 1) = ""
For i = 4 To irow
   If ar(i, 1) <> "" And ar(i, 2) = "" Then
   ar(i, 11) = ar(i, 1): ar(i, 1) = ""
   End If
   If ar(i, 11) = "" And ar(i - 1, 11) <> "" Then
     ar(i, 11) = ar(i - 1, 11)
   End If
   For j = 2 To icolumn
      If ar(i, j) <> "" Then
      If Not d.exists(ar(i, j)) Then
       d(ar(i, j)) = ar(i, 11) & ar(i, 1) & "," & ar(2, j)
      Else
        d(ar(i, j)) = d(ar(i, j)) & "," & ar(i, 11) & ar(i, 1) & "," & ar(2, j)
      End If
      End If
    Next
Next
irow1 = Sheets("查询").[a65536].End(xlUp).Row
icolumn1 = Sheets("查询").[iv2].End(xlToLeft).Column
br = Sheets("查询").[a1].Resize(irow1, icolumn1)
ReDim cr(1 To irow1, 1 To 20)
For k = 3 To irow1
   m = m + 1
   s = WorksheetFunction.Substitute(d(br(k, 1)), ",", "")
   t = Len(d(br(k, 1))) - Len(s) + 1
   If t > 1 Then
     For p = 1 To t
     cr(m, p) = Split(d(br(k, 1)), ",")(p - 1)
     Next
    End If
Next
Sheets("查询").[b3].Resize(500, icolumn1).ClearContents
Sheets("查询").[b3].Resize(m, 20) = cr
MsgBox "ok"
End Sub

翁知江安

以上供参考，欢迎批评指正。需要说明的是，查询表列数存在不够的情况，请留意。

ykcbf1100

今日123 发表于 2024-12-23 11:02
借用老师的代码 用一个取巧的方法写了一个
Sub 字典查询()
Dim arr, brr, i, j, crr, d As Object

你这代码仅适合本附件，有投机取巧的成份，其实完全可以不用取巧的。
帮你改了一下，应该更通用一点。

1. Sub 字典查询()
   
2.     Dim arr, brr, i, j, crr, d As Object
   
3.     Set d = CreateObject("Scripting.dictionary")
   
4.     With Sheets("数据表")
   
5.         arr = .[a2].CurrentRegion
   
6.         For i = 2 To UBound(arr)
   
7.             If arr(i, 2) = Empty Then st = arr(i, 1)
   
8.             For j = 2 To UBound(arr, 2)
   
9.                 If arr(i, j) <> Empty Then
   
10.                     d(arr(i, j)) = d(arr(i, j)) & st & arr(i, 1) & "|" & arr(1, j) & "|"
    
11.                 End If
    
12.             Next j
    
13.         Next i
    
14.     End With
    
15.     With Sheets("查询")
    
16.         brr = .[a2].CurrentRegion.Resize(, 20)
    
17.         r = 2
    
18.         For i = 2 To UBound(brr)
    
19.             If d.exists(brr(i, 1)) Then
    
20.                 crr = Split(d(brr(i, 1)), "|")
    
21.                 For j = 0 To UBound(crr)
    
22.                     brr(r, j + 2) = crr(j)
    
23.                 Next j
    
24.             End If
    
25.             r = r + 1
    
26.         Next i
    
27.         .[a2].CurrentRegion.Resize(, 20) = brr
    
28.     End With
    
29. End Sub
    

复制代码

今日123

ykcbf1100 发表于 2024-12-23 14:38
你这代码仅适合本附件，有投机取巧的成份，其实完全可以不用取巧的。
帮你改了一下，应该更通用一点。
...

谢谢老师指点