请各位大神帮忙，自己无能为力了

俘离

领导的要求有点复杂，实在有心无力了，求各位大神帮忙，有没有公式函数或者vba的方法能够达到自动分配的目的 问题.rar (8.63 KB, 下载次数: 6)

2018-8-8 10:35 上传

点击文件名下载附件

一把小刀闯天下

'空为未分配，自己修改

Option Explicit

Sub test()
  Dim arr, i, j, k, n, m, t, a, b
  arr = Range("a2:c" & Cells(Rows.Count, "a").End(xlUp).Row + 1)
  Call dsort(arr, 1, UBound(arr, 1) - 1, 2)
  Randomize
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      If arr(j, 2) <> arr(j + 1, 2) Then
        n = j - i + 1
        For a = i To j
          m = Int(Rnd * n)
          For b = 1 To UBound(arr, 2)
            t = arr(a, b): arr(a, b) = arr(i + m, b): arr(i + m, b) = t
        Next b, a
        For a = i To j - n Mod 4 Step 4
          arr(a, 3) = "院一": arr(a + 1, 3) = "院二"
          arr(a + 2, 3) = "院三": arr(a + 3, 3) = "院三"
        Next
        i = j: Exit For
      End If
  Next j, i
  Call dsort(arr, 1, UBound(arr, 1) - 1, 1)
  [d2].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub

Function dsort(arr, first, last, key)
  Dim i, j, k, t
  For i = first To last - 1
    For j = i + 1 To last
      If arr(i, key) > arr(j, key) Then
        For k = 1 To UBound(arr, 2)
          t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
        Next
      End If
  Next j, i
End Function

俘离

一把小刀闯天下 发表于 2018-8-8 11:18
'空为未分配，自己修改

Option Explicit

大神，多谢多谢，方案很有效，不过我是小白，想再冒昧请问下，如何将结果直接在C列显示，而不是将A、B、C列的数据重新在D、E、F列黏贴运算啊，另外。。。空是哪里呀- -

一把小刀闯天下

俘离 发表于 2018-8-8 11:32
大神，多谢多谢，方案很有效，不过我是小白，想再冒昧请问下，如何将结果直接在C列显示，而不是将A、B、C ...

'c列为空的就是未分配掉的物资，单种物资为空数=单种物资总数 mod 4，所以单种物资为空个数1-3个

'满意来朵小花，怎么老要提醒的

Option Explicit

Sub test()
  Dim arr, i, j, k, n, m, t, a, b
  arr = Range("a2:c" & Cells(Rows.Count, "a").End(xlUp).Row + 1)
  Call dsort(arr, 1, UBound(arr, 1) - 1, 2)
  Randomize
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      arr(j, 3) = vbNullString
      If arr(j, 2) <> arr(j + 1, 2) Then
        n = j - i + 1
        For a = i To j
          m = Int(Rnd * n)
          For b = 1 To UBound(arr, 2)
            t = arr(a, b): arr(a, b) = arr(i + m, b): arr(i + m, b) = t
        Next b, a
        For a = i To j - n Mod 4 Step 4
          arr(a, 3) = "院一": arr(a + 1, 3) = "院二"
          arr(a + 2, 3) = "院三": arr(a + 3, 3) = "院三"
        Next
        i = j: Exit For
      End If
  Next j, i
  Call dsort(arr, 1, UBound(arr, 1) - 1, 1)
  [a2].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub

Function dsort(arr, first, last, key)
  Dim i, j, k, t
  For i = first To last - 1
    For j = i + 1 To last
      If arr(i, key) > arr(j, key) Then
        For k = 1 To UBound(arr, 2)
          t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
        Next
      End If
  Next j, i
End Function

俘离

一把小刀闯天下 发表于 2018-8-8 11:45
'c列为空的就是未分配掉的物资，单种物资为空数=单种物资总数 mod 4，所以单种物资为空个数1-3个

'满 ...

不好意思 新人 找了半天才找到送花在哪儿- -大神 想再请问下 C列的空值 能在代码里就设定好结果表现为“未分配”而不是空白么？

一把小刀闯天下

俘离 发表于 2018-8-8 15:18
不好意思 新人 找了半天才找到送花在哪儿- -大神 想再请问下 C列的空值 能在代码里就设定好结果表现为“ ...

在 i = j: Exit For  这行上面插入一行代码：

For a = a To j: arr(a, 3) = "未分配": Next

俘离

一把小刀闯天下 发表于 2018-8-8 15:28
在 i = j: Exit For  这行上面插入一行代码：

For a = a To j: arr(a, 3) = "未分配": Next

万分感谢！！

俘离

一把小刀闯天下 发表于 2018-8-8 15:28
在 i = j: Exit For  这行上面插入一行代码：

For a = a To j: arr(a, 3) = "未分配": Next

大神，提示，编译错误：For控件变量已在使用怎么处理呀

一把小刀闯天下

俘离 发表于 2018-8-8 15:54
大神，提示，编译错误：For控件变量已在使用怎么处理呀

我试了一下没有问题，可以再上附件

问题1.zip (20.98 KB, 下载次数: 7)

2018-8-8 16:04 上传

点击文件名下载附件

俘离

一把小刀闯天下 发表于 2018-8-8 16:04
我试了一下没有问题，可以再上附件

那一行代码前面我少加了NEXT 再次谢谢大佬