把数据分成小组并交叉匹配输出

jd23qq

把数据分成小组并交叉匹配输出，希望高手帮助

chaohuahch

题目未看懂 系列

一把小刀闯天下

'"输出结果"看起来有点费劲

Option Explicit

Sub test()
  Dim i, j, k, dic, m, arr, a, b
  Set dic = CreateObject("scripting.dictionary")
  With Sheets("原始")
    arr = .Range("a2:m" & .Cells(Rows.Count, "a").End(xlUp).Row + 1)
  End With
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      If arr(j, 1) <> arr(j + 1, 1) Then
        m = m + 1: dic.RemoveAll
        For k = i To j
          If dic.exists(arr(k, 3)) Then m = m + 1: dic.RemoveAll
          arr(k, 13) = m: dic(arr(k, 3)) = vbNullString
        Next
        i = j: Exit For
      End If
  Next j, i
  ReDim brr(1 To Rows.Count, 1 To UBound(arr, 2) * 2): m = 0
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      If arr(j, 13) <> arr(j + 1, 13) Then
        For a = i To j
          For b = i To j
            If a <> b Then
              m = m + 1
              For k = 1 To UBound(arr, 2)
                brr(m, k) = arr(a, k)
                brr(m, UBound(arr, 2) + k) = arr(b, k)
              Next
            End If
        Next b, a
        i = j: Exit For
      End If
  Next j, i
  With Sheets("输出结果").[a2]
    .Resize(Rows.Count - 1, UBound(brr, 2)).ClearContents
    .Resize(m, UBound(brr, 2)) = brr
  End With
End Sub

jd23qq

一把小刀闯天下 发表于 2018-7-12 19:34
'"输出结果"看起来有点费劲

Option Explicit

第二次收到你的帮助，非常感谢。你太强大了

一把小刀闯天下

jd23qq 发表于 2018-7-12 20:09
第二次收到你的帮助，非常感谢。你太强大了

哈哈哈，就问题本身来说并没有难度，就是理解起来有点费劲。花了点时间看你的"输出结果"工作表，还好规律挺明显。