求助各位老师~！分组问题~！

xinyuan8751

求助各位老师帮忙~！

求助内容：

1、点击排序后，在E5列组别的单元格下出现对应的名称，如下图箭头指处自动跳出A5列对应名称的组别，即“脱水中盖”-----对应跳出“总装组”，组别按sheet2表中的分类。                                                  

2、调出组别后A5/B5/C5/E5/F5下的内容能够自动按组别排序，排序顺序为仪表组---电机组----总装组----打包组。                                                  

3、如果能实现把sheet2的内容写进代码，而不是建立sheet2工作表的话就完美了~！                                                                           

非常感谢~！                                                                                                        

此致

          敬礼

o^-^o                                                                                    

一把小刀闯天下

'根据提示把数据补全,不然无法排序，，，

Option Explicit

Sub test()
  Dim i, j, k, t, arr
  arr = Sheets("sheet2").UsedRange
  ReDim dic(5)
  For i = 0 To UBound(dic)
    Set dic(i) = CreateObject("scripting.dictionary")
  Next
  For j = 1 To UBound(arr, 2)
    dic(0)(j) = arr(1, j)
    dic(5)(arr(1, j)) = j
    For i = 3 To UBound(arr, 1)
      If Len(arr(i, j)) = 0 Then Exit For
      dic(j)(arr(i, j)) = j
  Next i, j
  Sheets("sheet1").Activate
  arr = Range("a6:n" & Cells(Rows.Count, "a").End(xlUp).Row)
  For i = 1 To UBound(arr, 1)
    For j = 1 To UBound(dic)
      If dic(j).exists(arr(i, 1)) Then
        arr(i, 5) = dic(0)(dic(j)(arr(i, 1)))
        Exit For
      End If
    Next
    If j = UBound(dic) + 1 Then
      [a6].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
      MsgBox arr(i, 1): Exit Sub
    End If
  Next
  Call bsort(arr, 1, UBound(arr, 1), 1, UBound(arr, 2), 5, dic(5))
  [a6].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub

Function bsort(arr, first, last, left, right, key, dic)
  Dim i, j, k, t
  For i = first To last - 1
    For j = first To last + first - 1 - i
      If dic(arr(j, key)) > dic(arr(j + 1, key)) Then
        For k = left To right
          t = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = t
        Next
      End If
  Next j, i
End Function

xinyuan8751

一把小刀闯天下 发表于 2019-6-14 11:34
'根据提示把数据补全,不然无法排序，，，

Option Explicit

老师能发个压缩文件格式的吗？ 谢谢~非常感谢~！！！

一把小刀闯天下

xinyuan8751 发表于 2019-6-14 13:55
老师能发个压缩文件格式的吗？ 谢谢~非常感谢~！！！

'有3个名称无组别，自己处理，，，

求助1.zip (74.07 KB, 下载次数: 4)

2019-6-14 14:08 上传

点击文件名下载附件

xinyuan8751

一把小刀闯天下 发表于 2019-6-14 11:34
'根据提示把数据补全,不然无法排序，，，

Option Explicit

谢谢老师，万分感谢~！
此致
      敬礼

xinyuan8751

一把小刀闯天下 发表于 2019-6-14 14:09
'有3个名称无组别，自己处理，，，

谢谢老师，谢谢~

敬礼