按条件提取信息，较难，请大神帮助，谢谢。

花菲飞 · 发表于 2024-12-13 18:07

鄂龙蒙 · 发表于 2024-12-13 18:28

【自习时段座位】安排是什么规则？

简七 · 发表于 2024-12-13 19:31

第二个理理到底什么规则

花菲飞 · 发表于 2024-12-13 19:40

简七发表于 2024-12-13 19:31
第二个理理到底什么规则

考场为高三1班座位号1，自习填写为：高三1班学号1的相关信息。因高三1班考场只有42个座位，高三1班43号学生就要到德正1室座位1进行自习了，其他同理。谢谢您。

花菲飞 · 发表于 2024-12-13 19:41

简七发表于 2024-12-13 19:31
第二个理理到底什么规则

写错了，应该是德正1而不是7

花菲飞 · 发表于 2024-12-13 19:43

鄂龙蒙发表于 2024-12-13 18:28
【自习时段座位】安排是什么规则？

考场为高三1班座位号1，自习填写为：高三1班学号1的相关信息。因高三1班考场只有42个座位，高三1班43号学生就要到德正1室座位1进行自习了，其他同理。谢谢您。

chxw68 · 发表于 2024-12-13 20:22

Sub test()
Dim r%, i%, m%
Dim arr, brr(), zrr()
Dim d As Object
Dim reg As New RegExp
Dim flg As Boolean
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With reg
.Global = False
.Pattern = "高三（(\d+)）班"
End With
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
With Worksheets("数据")
r = .Cells(.Rows.Count, 16).End(xlUp).Row
arr = .Range("p4:p" & r)
For i = 1 To UBound(arr)
Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
Next
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:j" & r)
End With
For i = 1 To UBound(arr)
If d.exists(arr(i, 7)) Then
d(arr(i, 7))(i) = Empty
End If
If Not d1.exists(arr(i, 4)) Then
Set d1(arr(i, 4)) = CreateObject("scripting.dictionary")
End If
d1(arr(i, 4))(arr(i, 5)) = arr(i, 2)
Next
flg = True
For Each aa In d.keys
If d(aa).Count > 0 Then
On Error Resume Next
Worksheets(aa).Delete
On Error GoTo 0
Worksheets("模板").Copy after:=Worksheets(Worksheets.Count)
With ActiveSheet
.Name = aa
m = 2
n = 1
For Each bb In d(aa).keys
.Cells(m, n + 1) = arr(bb, 3)
.Cells(m + 1, n + 1) = arr(bb, 2)
.Cells(m + 1, n + 3) = arr(bb, 4)
.Cells(m + 2, n + 1) = arr(bb, 7)
.Cells(m + 2, n + 3) = arr(bb, 8)
.Cells(m + 3, n + 1) = arr(bb, 9)
.Cells(m + 3, n + 3) = arr(bb, 10)
If reg.test(aa) Then
Set mh = reg.Execute(aa)
bj = Val(mh(0).SubMatches(0))
If d1.exists(bj) Then
If d1(bj).exists(arr(bb, 8)) Then
.Cells(m + 5, n + 1) = bj
.Cells(m + 5, n + 3) = d1(bj)(arr(bb, 8))
d1(bj).Remove (arr(bb, 8))
If d1(bj).Count = 0 Then
d1.Remove (bj)
End If
End If
End If
Else
If flg Then
x = 0
If d1.Count > 0 Then
For k = Application.Min(d1.keys) To Application.Max(d1.keys)
If d1.exists(k) Then
For q = Application.Min(d1(k).keys) To Application.Max(d1(k).keys)
If d1(k).exists(q) Then
x = x + 1
ReDim Preserve zrr(1 To x)
zrr(x) = Array(k, d1(k)(q))
End If
Next
End If
Next
End If
x = 0
flg = False
End If
x = x + 1
If x <= UBound(zrr) Then
.Cells(m + 5, n + 1) = zrr(x)(0)
.Cells(m + 5, n + 3) = zrr(x)(1)
End If
End If
n = n + 5
If n > 11 Then
n = 1
m = m + 7
End If
Next
End With
End If
Next
End Sub

复制代码

chxw68 · 发表于 2024-12-13 20:24

参与一下。

chxw68 · 发表于 2024-12-13 21:03

修改了一下，避免每个表格最下边出现空表格。

花菲飞 · 发表于 2024-12-14 07:27

chxw68 发表于 2024-12-13 21:03
修改了一下，避免每个表格最下边出现空表格。

谢谢大神您的帮助，还进一步优化了，太强了，太感谢了。

		自动登录	找回密码
密码			免费注册

[求助] 按条件提取信息，较难，请大神帮助，谢谢。