根据要求生成矩阵，谢谢

liumahao

向各位大大请教一个数据矩阵生成的问题
现有数据如图：标红为存在重复的情况

由于数据量巨大，编号有900个，姓名有3500个，想生成如下矩阵：规则是编号和姓名对应时候赋值为1，不对应时赋值为0，且新生成的矩阵名字这一列无重复姓名，有同一人对应不同的编号时，则直接在同一行不同列的相应位置赋值为1.

如果删除重复姓名难度大，可不删除重复姓名，只要赋值完毕就可。
待处理.zip (91.17 KB, 下载次数: 19)

2018-7-18 00:59 上传

点击文件名下载附件

一把小刀闯天下

'数据量大，速度有点慢，15s左右

'匹配成功为1，否则为空，自己修改(vbnullstring改成"0")

Option Explicit

Sub test()
  Dim arr, t As String, dic, i As Long, j As Long, dt
  dt = Timer
  Set dic = CreateObject("scripting.dictionary")
  arr = Sheets("sheet1").[a1].CurrentRegion.Value
  For i = 1 To UBound(arr, 1)
    t = arr(i, 1) & arr(i, 2): dic(t) = vbNullString
  Next
  Debug.Print Timer - dt
  arr = Sheets("sheet2").[a1].CurrentRegion.Value
  Debug.Print Timer - dt
  For i = 2 To UBound(arr, 1)
    For j = 2 To UBound(arr, 2)
      t = arr(1, j) & arr(i, 1)
      If dic.exists(t) Then arr(i, j) = "1" Else arr(i, j) = vbNullString
  Next j, i
  Debug.Print Timer - dt
  With Sheets("sheet2").[a1]
    .Resize(, UBound(arr, 2)).NumberFormatLocal = "@"
    .CurrentRegion.Value = arr
  End With
  Debug.Print Timer - dt
End Sub

liulang0808

http://club.excelhome.net/thread-1385473-1-1.html
这个字典的帖子楼主可以参考下的

liumahao

一把小刀闯天下 发表于 2018-7-18 03:36
'数据量大，速度有点慢，15s左右

'匹配成功为1，否则为空，自己修改(vbnullstring改成"0")

太感谢了，你太厉害了，能简单说下思想么

liumahao

liulang0808 发表于 2018-7-18 07:00
http://club.excelhome.net/thread-1385473-1-1.html
这个字典的帖子楼主可以参考下的

同样感谢，授人以渔，谢谢

chaohuahch

一把小刀闯天下 发表于 2018-7-18 03:36
'数据量大，速度有点慢，15s左右

'匹配成功为1，否则为空，自己修改(vbnullstring改成"0")

看你这思路。和字典的嵌套很像呀。

liumahao

一把小刀闯天下 发表于 2018-7-18 03:36
'数据量大，速度有点慢，15s左右

'匹配成功为1，否则为空，自己修改(vbnullstring改成"0")

想问下：
t = arr(i, 1) & arr(i, 2): dic(t) = vbNullString
这一句是啥意思

一把小刀闯天下

chaohuahch 发表于 2018-7-18 11:37
看你这思路。和字典的嵌套很像呀。

没有，就是普通的单字典而已，不会用字典嵌套

一把小刀闯天下

liumahao 发表于 2018-7-18 11:43
想问下：
t = arr(i, 1) & arr(i, 2): dic(t) = vbNullString
这一句是啥意思

没啥意思，可以写成这样，看上去有点别扭而已

dic(arr(i, 1) & arr(i, 2)) =""