请教老师：提取相同序号所对应数据及单元格颜色

zainan0810

请教老师：
1、说明：A列是序号（不一定是连续数字）；B:K列是数据源，每次有1~10列不等，每列长度不等。


2、计算：M列输入任意N个序号，提取在A列有相同序号的行，按原样（数据位置及单元格颜色），放在M列序号的后面。


比如：M2=33，在A列是找到33（A33），把此行原样放到M2的后面。

具体请见例子： 提取相同序号所对应数据及单元格颜色.rar (8.89 KB, 下载次数: 8)

2024-2-14 12:18 上传

点击文件名下载附件

ykcbf1100

附件供参考。。。

附件已更新。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.2.14
   
2.     r = Me.Cells(Rows.Count, 1).End(3).Row
   
3.     r1 = Me.Cells(Rows.Count, "m").End(3).Row
   
4.     arr = Me.Range("m1:m" & r1)
   
5.     For i = 1 To UBound(arr)
   
6.         Me.Cells(arr(i, 1), 1).Resize(1, 5).Copy Me.Cells(i, "T")
   
7.     Next
   
8.     MsgBox "OK！"
   
9. End Sub
   
10. 
    

复制代码

zainan0810

ykcbf1100 发表于 2024-2-14 13:12
附件供参考。。。

谢谢老师的辛苦！还得请老师帮下忙，这个文件的代码我找不到了。

ykcbf1100

zainan0810 发表于 2024-2-14 14:02
谢谢老师的辛苦！还得请老师帮下忙，这个文件的代码我找不到了。

晕，上传时没有另存为xlsm文件了。
代码其实已经上传，稍等一下，在下面一个楼层中。

zainan0810

ykcbf1100 发表于 2024-2-14 13:12
参与一下。。。

谢谢老师，祝您节日快乐！

gwjkkkkk

Sub TEST5()
    Dim ar, i&, dic As Object
   
    Set dic = CreateObject("Scripting.Dictionary")
   
    With [A1].CurrentRegion
        ar = .Value
        For i = 1 To UBound(ar)
            Set dic(ar(i, 1)) = .Rows(i)
        Next i
    End With
    With Range("M1", Cells(Rows.Count, "M").End(xlUp))
        ar = .Value
        For i = 1 To UBound(ar)
            If dic.exists(ar(i, 1)) Then
                dic(ar(i, 1)).Copy .Cells(i, 1)
            End If
        Next i
    End With
   
    Set dic = Nothing
    Beep
End Sub

gwjkkkkk

字典法，参与一下。。。

zainan0810

gwjkkkkk 发表于 2024-2-14 17:36
Sub TEST5()
    Dim ar, i&, dic As Object
   

谢谢gwjkkkkk老师的指教！收藏了