|
|
Sub 按钮1_Click()
Application.ScreenUpdating = False
If [c2] = 12 Then
d = 31
Else
d = Day(CDate([c1] & "-" & [c2] + 1 & "-1") - 1)
End If
[m3:aq4].ClearContents
[m3:aq4].Interior.ColorIndex = xlNone
For j = 1 To d
Cells(3, j + 12) = j
Cells(4, j + 12) = Format(CDate([c1] & "-" & [c2] & "-" & j), "AAA")
If Cells(4, j + 12) = "周日" Then Cells(4, j + 12).Interior.ColorIndex = 3
Next j
y = 12 + d
l2:
ww = 0
ActiveSheet.UsedRange.Offset(4, 11).ClearContents
ActiveSheet.UsedRange.Offset(4, 11).Interior.ColorIndex = xlNone
arr = ActiveSheet.UsedRange
Set dd = CreateObject("scripting.dictionary")
For j = 5 To UBound(arr)
If Len(arr(j, 2)) > 0 Then
ww = 0
dd.RemoveAll
For i = 3 To 9
If arr(j, i) > 0 Then
dd(i) = arr(j, i)
End If
Next i
l1:
If dd.Count > 0 Then
x = WorksheetFunction.RandBetween(0, dd.Count - 1)
k = dd.keys()(x)
zz = dd(k)
For i = 13 To y Step 3
For x = i To y
If Len(arr(j, x)) = 0 And arr(4, x) <> "周日" Then
If (Cells(j, x - 1) <> Cells(4, k) And WorksheetFunction.CountIf(Cells(j, x + 1).Resize(1, 2), arr(4, k)) <> 2) Or (Cells(j, x + 1) <> Cells(4, k) And WorksheetFunction.CountIf(Cells(j, x - 2).Resize(1, 2), arr(4, k)) <> 2) Then
dd(k) = dd(k) - 1
arr(j, x) = arr(4, k)
Cells(j, x) = arr(4, k)
Cells(j, x).Interior.ColorIndex = arr(4, k) + 2
If dd(k) = 0 Then
dd.Remove k
GoTo l1
End If
Exit For
End If
End If
Next x
Next
ww = ww + 1
If ww > 100 Then GoTo l2
GoTo l1
End If
End If
Next j
Application.ScreenUpdating = True
End Sub
|
|
楼主: 恒信人才
沪公网安备 31011702000001号 沪ICP备11019229号-2
楼主
发表于 2023-5-23 08:23
