从数据源根据表格名字以及行合列的关键字提取数据

river4403

从附件的数据源，可否根据表格的名字，表头（数据列），内容的关键字（数据行），提取对应的数据。

LIUZHU

数据不是很规范，用代码得先整理数据，有点麻烦

LIUZHU

用公式整理了一个，为了让公式不至于太长，读起来麻烦，在D列增加列1列辅助列
=INDEX(OFFSET(数据源!$A$1:$AA$639,MATCH(INDIRECT("A"&$D6),数据源!$A:$A,),),MATCH($A6,OFFSET(数据源!$A$1:$A$639,MATCH(INDIRECT("A"&$D6),数据源!$A:$A,),),),MATCH(INDIRECT(ADDRESS($D6,COLUMN())),数据源!$6:$6,))

LIUZHU

看看数据是否正确？

LIUZHU

附件，请审核

ykcbf1100

这题有点难，附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.28
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set d1 = CreateObject("scripting.dictionary")
   
6.     Set sh = ThisWorkbook.Sheets("数据源")
   
7.     With sh
   
8.         r = .Cells(Rows.Count, 1).End(3).Row
   
9.         arr = .Range("A1:aa" & r)
   
10.     End With
    
11.     u = UBound(arr, 2)
    
12.     On Error Resume Next
    
13.     For i = 1 To r
    
14.         If InStr(arr(i, 1), "#page") Then
    
15.             n = n + 1
    
16.             d1(n) = i
    
17.         End If
    
18.     Next
    
19.     ReDim brr(1 To UBound(arr), 1 To 2)
    
20.     For k = 1 To d1.Count
    
21.         r1 = d1(k)
    
22.         If k = d1.Count Then r2 = r Else r2 = d1(k + 1) - 1
    
23.         For i = r1 + 6 To r2
    
24.             If arr(i, 1) <> Empty Then
    
25.                 If InStr(arr(i, 1), "Table") = 0 Then
    
26.                     For j = 2 To UBound(arr, 2)
    
27.                         s = Trim(arr(r1 + 2, 1)) & "|" & Trim(arr(i, 1)) & "|" & Trim(arr(r1 + 5, j))
    
28.                         d(s) = arr(i, j)
    
29.                     Next
    
30.                 End If
    
31.             End If
    
32.         Next
    
33.     Next
    
34.     On Error Resume Next
    
35.     For Each sht In Sheets
    
36.         If sht.Name <> sh.Name Then
    
37.             With sht
    
38.                 r = .Cells(Rows.Count, 1).End(3).Row
    
39.                 arr = .[a1].Resize(r, 3)
    
40.                 For i = 5 To UBound(arr)
    
41.                     If arr(i, 1) <> Empty Then
    
42.                         If InStr(arr(i, 1), "*") Then
    
43.                             lr = i
    
44.                             i = i + 1
    
45.                         End If
    
46.                         For j = 2 To UBound(arr, 2)
    
47.                             s = Trim(arr(lr, 1)) & "|" & Trim(arr(i, 1)) & "|" & Trim(arr(lr, j))
    
48.                             If d.exists(s) Then
    
49.                                 arr(i, j) = d(s)
    
50.                             End If
    
51.                         Next
    
52.                         
    
53.                     End If
    
54.                 Next
    
55.                 .[a1].Resize(r, 3) = arr
    
56.             End With
    
57.         End If
    
58.     Next
    
59.     Set d = Nothing
    
60.     Set d1 = Nothing
    
61.     Application.ScreenUpdating = True
    
62.     MsgBox "OK！"
    
63. End Sub
    
64. 
    

复制代码

river4403

ykcbf1100 发表于 2024-4-28 16:41
这题有点难，附件供参考。。。

成功了，非常感谢！

river4403

LIUZHU 发表于 2024-4-28 15:57
看看数据是否正确？

正确的，这种方法也行哦！感谢感谢！

river4403

ykcbf1100 发表于 2024-4-28 16:42
参与一下。。。

很棒，非常感谢！