将2模矩阵转换为1模矩阵

liumahao

现有姓名-编号矩阵如图，

想将这个矩阵转换为姓名-姓名矩阵，大概如下（下图有错误），如果两个人归属同一编号，如李小加和齐大庆都属于000002，则在新矩阵相应的交点处赋值为1，如果对应不同编号，如李小加和刘家胜，则赋值为0，下图的错误是本人对本人应该赋值为0，而不是1或者2.

其实如果能生成图2也可以，后续我可以自己再修改，谢谢大神了。数据量很大，估计要用VBA实现。
待处理 (2).zip (1.16 MB, 下载次数: 12)

2018-7-19 10:56 上传

点击文件名下载附件

chaohuahch

你的名字不是唯一值，有重名的。好像有13个重名的。

liumahao

chaohuahch 发表于 2018-7-19 13:10
你的名字不是唯一值，有重名的。好像有13个重名的。

13个重名但是是不同的人

一把小刀闯天下

'0用空替代，可把注释去除不满足条件就为0

'数据量较大，大概需要15s

Option Explicit

Sub test()
  Dim arr, i As Long, j As Long, k As Long, t, dic, dt, s As String
  dt = Timer
  Set dic = CreateObject("scripting.dictionary")
  arr = Sheets("sheet1").[a1].CurrentRegion.Value
  For j = 2 To UBound(arr, 2)
    For i = 2 To UBound(arr, 1)
      If arr(i, j) = 1 Then
        If dic.exists(arr(i, 1)) Then
          If InStr(dic(arr(i, 1)), arr(1, j) & "|") = 0 Then
            dic(arr(i, 1)) = dic(arr(i, 1)) & arr(1, j) & "|"
          End If
        Else
          dic(arr(i, 1)) = arr(1, j) & "|"
        End If
      End If
  Next i, j
  Debug.Print Timer - dt
  With Sheets("sheet2")
    arr = .[a1].CurrentRegion.Value
    .[b2].Resize(UBound(arr, 1) - 1, UBound(arr, 2)).ClearContents
    arr = .[a1].CurrentRegion.Value
  End With
  Debug.Print Timer - dt
  For j = 2 To UBound(arr, 2)
    s = dic(arr(1, j))
    For i = 2 To UBound(arr, 1)
      If arr(i, 1) = arr(1, j) Then
'        arr(i, j) = "0"
      Else
        t = Split(dic(arr(i, 1)), "|")
        For k = 0 To UBound(t)
          If Len(t(k)) > 0 Then
            If InStr(s, t(k) & "|") > 0 Then
              arr(i, j) = "1": Exit For
            End If
          End If
        Next
'        If k = UBound(t) + 1 Then arr(i, j) = "0"
      End If
  Next i, j
  Debug.Print Timer - dt
  Sheets("sheet2").[a1].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
  Debug.Print Timer - dt
End Sub

香川群子

数组计算只需0.5秒，但是输出结果需要5秒。

本人对本人结果=0，也做了。

chaohuahch

一把小刀闯天下 发表于 2018-7-19 13:54
'0用空替代，可把注释去除不满足条件就为0

'数据量较大，大概需要15s

此表有2486个人名。但是有13个是重复的。所以您写代码dic.count 是2472  。需要楼主吧13个重复的值挑出来。来验证此代码运行的结果，是否正确。

香川群子

chaohuahch 发表于 2018-7-19 13:10
你的名字不是唯一值，有重名的。好像有13个重名的。

我检查了一下，重名的有14人：

1 陈国辉
2 陈新
3 李桂荣
4 李军
5 李平
6 梁定邦
7 刘平
8 刘伟
9 濮洪九
10 王志强
11 徐军
12 杨光
13 张海霞
14 张建平

香川群子

一把小刀闯天下 发表于 2018-7-19 13:54
'0用空替代，可把注释去除不满足条件就为0

'数据量较大，大概需要15s

无需使用字典。

用纯数组即可，计算耗时仅需0.5秒。

但是输出2487行*2487列的结果，需要5秒以上。

chaohuahch

香川群子 发表于 2018-7-19 13:57
数组计算只需0.5秒，但是输出结果需要5秒。

本人对本人结果=0，也做了。

br(j)(k) = i 这一句学习了。没想到一维数组，还可以这样用！

chaohuahch

香川群子 发表于 2018-7-19 14:12
无需使用字典。

用纯数组即可，计算耗时仅需0.5秒。

Sheet2.Activate 两次使用Activate 如果使用with的话。运行速度，会不会更快？