提取列

ddz79101

老师，希望能跨表提取列名一致数据到指定列名的表格中，望老师赐教。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.1.21
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("Sheet1")
   
6.         r = .Cells(.Rows.Count, "g").End(xlUp).Row
   
7.         arr = .[g5].Resize(r, 3)
   
8.     End With
   
9.     For i = 2 To UBound(arr)
   
10.         m = m + 1
    
11.         For j = 1 To UBound(arr, 2)
    
12.             s = arr(1, j) & "|" & m
    
13.             d(s) = arr(i, j)
    
14.         Next
    
15.     Next
    
16.     m = 0
    
17.     With Sheets("Sheet2")
    
18.         r = .Cells(.Rows.Count, "d").End(xlUp).Row
    
19.         arr = .Range("d5:i" & r)
    
20.         .[p6:u1000] = ""
    
21.         For i = 2 To UBound(arr)
    
22.             m = m + 1
    
23.             For j = 1 To UBound(arr, 2)
    
24.                 s = arr(1, j) & "|" & m
    
25.                 If d.Exists(s) Then
    
26.                     arr(i, j) = d(s)
    
27.                 End If
    
28.             Next
    
29.             .[p5].Resize(m + 1, UBound(arr, 2)) = arr
    
30.         Next
    
31.     End With
    
32.     Set d = Nothing
    
33.     Application.ScreenUpdating = True
    
34.     MsgBox "OK！"
    
35. End Sub
    

复制代码

ykcbf1100

附件供参考。。。

ddz79101

ykcbf1100 发表于 2024-1-21 10:38
附件供参考。。。

谢谢老师！提取成功。但有个问题，我希望是将提取的数据嵌入原表中，因为原表已有数据，若另起炉灶，还要在操作一遍。

ddz79101

我已用Range("g6:g200").Copy Sheets(2).[e6]，但感觉有点单簿。

ykcbf1100

ddz79101 发表于 2024-1-21 11:01
谢谢老师！提取成功。但有个问题，我希望是将提取的数据嵌入原表中，因为原表已有数据，若另起炉灶，还要 ...

改好了。。。

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, i&, j&, dic As Object
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    With Sheets(1).[G5].CurrentRegion
        ar = .Value
        For j = 1 To UBound(ar, 2)
            With .Columns(j)
                Set dic(ar(1, j)) = Intersect(.Offset(), .Offset(1))
            End With
        Next j
    End With
    With [A5].CurrentRegion
        ar = .Value
        For j = 1 To UBound(ar, 2)
            If dic.exists(ar(1, j)) Then dic(ar(1, j)).Copy .Cells(2, j)
        Next j
    End With
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考 附件。。。

ddz79101

ykcbf1100 发表于 2024-1-21 11:06
改好了。。。

谢谢老师！成功运行。但我上面表述的不正确，原因是sheet2中现有的不是数据而是函数公式，所以导致虽嵌入但原列数据出错了。今天有其它事，待我忙完后集中整理几张连续表再向老师请教。谢谢！

ddz79101

gwjkkkkk 发表于 2024-1-21 11:52
请参考 附件。。。

谢谢老师！运行成功