表2如何根据表1的排序生成到表3？

huizhuzi

zjdh 发表于 2018-7-14 15:10
你的表达不懂！

自己重新弄了，请看新的附件，求表4的效果(*^__^*) 嘻嘻

huizhuzi

不知道为什么 发表于 2018-7-14 15:10
没觉得题目难，是觉得理解提问者的意图更难！
先把你想要的说清楚

自己重新弄了，请看新的附件，求表4的效果(*^__^*) 嘻嘻

huizhuzi

182197315 发表于 2018-7-17 21:01
难道运行的结果不是这样的吗？

自己重新弄了，请看新的附件，求表4的效果(*^__^*) 嘻嘻

huizhuzi

只能做到表3，如何可以做到表4的效果？

huizhuzi

顶一顶，求大神

一把小刀闯天下

huizhuzi 发表于 2018-7-21 10:34
顶一顶，求大神

'20楼附件，猜一个

Option Explicit

Sub test()
  Dim arr, dic, i, j, m, n, pos
  Set dic = CreateObject("scripting.dictionary")
  arr = Sheets("1").[a1].CurrentRegion
  For i = 2 To UBound(arr, 1)
    If Not dic.exists(arr(i, 4)) Then n = n + 1: dic(arr(i, 4)) = n
  Next
  arr = Sheets("2").[a1].CurrentRegion
  ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2)): n = 0
  For i = 2 To UBound(arr, 1)
    If dic.exists(arr(i, 4)) Then
      n = n + 1: brr(n, 1) = n
      For j = 2 To UBound(arr, 2): brr(dic(arr(i, 4)), j) = arr(i, j): Next
    Else
      MsgBox "!!": Exit Sub
    End If
  Next
  ReDim mark(1 To UBound(arr, 2))
  For i = 1 To UBound(mark): mark(i) = arr(1, i): Next
  i = n \ 40 + IIf(n Mod 40 = 0, 0, 1)
  ReDim arr(1 To 80, 1 To UBound(brr, 2) * i)
  For i = 1 To n
    m = m + 1
    For j = 1 To UBound(brr, 2)
      arr((m - 1) * 2 + 1, pos + j) = mark(j)
      arr((m - 1) * 2 + 2, pos + j) = brr(i, j)
    Next
    If m Mod 40 = 0 Then m = 0: pos = pos + UBound(brr, 2)
  Next
  With Sheets("3").[a2]
    .Resize(Rows.Count - 1, UBound(brr, 2)).ClearContents
    If n > 0 Then .Resize(n, UBound(brr, 2)) = brr
  End With
  With Sheets("4").[a1]
    .Resize(Rows.Count, UBound(arr, 2)).ClearContents
    if n>0 then .Resize(UBound(arr, 1), UBound(arr, 2)) = arr
  End With
End Sub

huizhuzi

一把小刀闯天下 发表于 2018-7-21 11:15
'20楼附件，猜一个

Option Explicit

接近了，但是序号为80一页，序号81紧接序号40，不是一直往右

huizhuzi

一把小刀闯天下 发表于 2018-7-21 11:15
'20楼附件，猜一个

Option Explicit

闯天下大侠，有办法吗？

不知道为什么

对小刀老师的义务帮助没看到你表示一点谢意啊，感觉像领导在布置工作哎。

huizhuzi

不知道为什么 发表于 2018-7-26 20:49
对小刀老师的义务帮助没看到你表示一点谢意啊，感觉像领导在布置工作哎。

误会误会，绝对没有这意思。很感谢闯天下老师的