用VBA如何实现身份证列按文本格式粘贴

fjgzs1

VBA中按T列关键字查询数据，能对数据进行筛选，但是身份证号列出错，筛选后的数据不是文本，导致最后四位数值为0，请问让身份号列格式不出错！
代码如下：

Sub 按T关键字筛选()

Set d =CreateObject("scripting.dictionary")

Dimcrr(1 To 55000, 1 To 18)

   With Sheets(“数据结果”)

       irow = .Cells(.Rows.Count, 20).End(xlUp).Row

      arr = .Range("t1:t" & irow)

   End With

   With Sheets("数据源")

      imax = .Cells(.Rows.Count, 1).End(xlUp).Row

      brr = .Range("A2:R" & imax)

   End With

   For K = 2 To UBound(arr)

        For n = 1 To UBound(brr)

           If InStr(brr(n, 1), arr(K, 1)) > 0 Then

            d(arr(K, 1)) = d(arr(K, 1)) + 1

              m = m + 1

              crr(m, 1) = brr(n, 1)

              crr(m, 2) = brr(n, 2)

              crr(m, 3) = brr(n, 3)

              crr(m, 4) = brr(n, 4)

              crr(m, 5) = brr(n, 5)

              crr(m, 6) = brr(n, 6)

              crr(m, 7) = brr(n, 7)

crr(m, 8) = brr(n, 8)

crr(m, 9) = brr(n, 9)

crr(m, 10) = brr(n, 10)

crr(m, 11) = brr(n, 11)

crr(m, 12) = brr(n, 12)

crr(m, 13) = brr(n, 13)

crr(m, 14) = brr(n, 14)

crr(m, 15) = brr(n, 15)

crr(m, 16) = brr(n, 16)

crr(m, 17) = brr(n, 17)

crr(m, 18) = brr(n, 18)

                                      

           End If

        Next

   Next

    d_n = d.items

    d_k = d.keys

    Sheets(“数据结果”).Range("A2:r45000") = ""

    Sheets(“数据结果”).Range("t2:u" & irow) = ""   

    Sheets(“数据结果”).Range("A2").Resize(m, 18) = crr

    Sheets(“数据结果”).Range("t2").Resize(d.Count, 1) = Application.Transpose(d_k)

    Sheets(“数据结果”).Range("u2").Resize(d.Count, 1) =Application.Transpose(d_n)

   MsgBox "完成", 0 + 64, "提示"

End Sub

按J列关键筛选并要筛选结果是文本.rar (53.68 KB, 下载次数: 52)

2019-1-15 15:27 上传

点击文件名下载附件

yayahzmeng

小小改动一下，供参考

1. Sub 按T列的关键字筛选2()
   
2.     On Error Resume Next
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     arr = Sheets("数据结果").[t1].CurrentRegion
   
5.     brr = Sheets("数据源").[a1].CurrentRegion
   
6.     Dim crr: ReDim crr(1 To UBound(brr), 1 To 18)
   
7.     For K = 2 To Sheets("数据结果").[t65536].End(3).Row
   
8.          For n = 2 To UBound(brr)
   
9.             If InStr(brr(n, 1), arr(K, 1)) Then
   
10.                 d(arr(K, 1)) = d(arr(K, 1)) + 1
    
11.                 m = m + 1
    
12.                 For i = 1 To 18: crr(m, i) = "'" & brr(n, i): Next  '强制文本
    
13.             End If
    
14.          Next
    
15.     Next
    
16.     Sheets("数据结果").Range("A2:r45000") = ""
    
17.     Sheets("数据结果").Range("t2:u" & irow) = ""
    
18.     Sheets("数据结果").Range("A2").Resize(m, 18) = crr
    
19.     Sheets("数据结果").Range("t2").Resize(d.Count, 1) = Application.Transpose(d.keys)
    
20.     Sheets("数据结果").Range("u2").Resize(d.Count, 1) = Application.Transpose(d.items)
    
21.     MsgBox "完成", 0 + 64, "提示"
    
22. End Sub

复制代码

fjgzs1

yayahzmeng 发表于 2019-1-15 22:53
小小改动一下，供参考

你真是大师！能按文本格式粘贴了！

fjgzs1

yayahzmeng 发表于 2019-1-15 22:53
小小改动一下，供参考

如何想实现不是按T列的关键字，而是任意选择关键字所在列和任意选择要筛选的列（第一步选择关键字列，第二步选择要进行筛选的列）这样可以实现吗？

zpy2

fjgzs1 发表于 2019-1-19 22:29
如何想实现不是按T列的关键字，而是任意选择关键字所在列和任意选择要筛选的列（第一步选择关键字列，第 ...

关键字目测附件是在a列啊？
如何想实现不是按T列的关键字，
是啥意思啊？

zpy2

fjgzs1 发表于 2019-1-19 22:29
如何想实现不是按T列的关键字，而是任意选择关键字所在列和任意选择要筛选的列（第一步选择关键字列，第 ...

是不是要按关键词搜索筛选啊？

fjgzs1

zpy2 发表于 2019-1-20 10:36
关键字目测附件是在a列啊？
如何想实现不是按T列的关键字，
是啥意思啊？

意思有时候关键字不放在T列，而是放在其他列，我们可以第一步手动找到关键字列，第二步再去找要筛选列（也不一定是A列，可能是在其他列），这样这个筛选就是就是万能型的了！

zpy2

fjgzs1 发表于 2019-1-20 21:25
意思有时候关键字不放在T列，而是放在其他列，我们可以第一步手动找到关键字列，第二步再去找要筛选列（ ...

http://club.excelhome.net/thread-1457819-3-1.html
可以参考一下这个帖子里不同方法，还有我发的链接。

fjgzs1

zpy2 发表于 2019-1-21 06:34
http://club.excelhome.net/thread-1457819-3-1.html
可以参考一下这个帖子里不同方法，还有我发的链接 ...

看了你发的链接里的表，发现筛选的关键字是单个的，我要有一列的（多个的），不知可不可以帮修改一下！

mhps159357

这种弱智问题也发出来，直接选中“数据结果”里面的E列，设置成文本格式，在运行代码就可以了！