考场表格拆分，求大神解决

zqlpop308 · 发表于 2020-1-12 07:23

说明1：把表格Sheet1中的考场情况拆分自动生成各班的表格，其中只要”行政班、学号、姓名、各科考场汇总“
说明2：把表格Sheet1中的考场情况拆分自动生成各学科的考场表格，同时要求按考场顺序排列+按座位号顺序排列
说明3：字段请见后两个表格，谢谢
求大神解决

zpy2 · 发表于 2020-1-12 09:17

这种感觉需要查询比较方便，班级多，拆分可能还要分发。
下面的sql语句供参考

zqlpop308 · 发表于 2020-1-12 09:24

zpy2 发表于 2020-1-12 09:17
这种感觉需要查询比较方便，班级多，拆分可能还要分发。
下面的sql语句供参考

这个对于我这种小白来说太难了，我还是想用vba来解决这种问题

micch · 发表于 2020-1-12 09:34

数据源很详细，都已经处理好了，直接透视表吧

鄂龙蒙 · 发表于 2020-1-12 11:35

按班级拆分

考场拆分.rar (88.9 KB, 下载次数: 9)

zqlpop308 · 发表于 2020-1-12 12:25

鄂龙蒙发表于 2020-1-12 11:35
按班级拆分

谢谢你，考场拆分能解决么？谢谢

excel海 · 发表于 2020-1-12 13:27

前面的班级考场分布已写好,后面的也差不多,你自己改下吧
Sub test()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rng As Range
Dim n, arr, brr, crr, i, j
n = Sheet1.Cells(Rows.Count, 1).End(3).Row
arr = Sheet1.Range("A1:C" & n)
brr = Sheet1.Range("Z1:Z" & n)
ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2) + UBound(brr, 2))
For i = 1 To UBound(arr)
      For j = 1 To UBound(arr, 2)
         crr(i, j) = arr(i, j)
      Next
      For j = 1 To UBound(brr, 2)
         crr(i, j + UBound(arr, 2)) = brr(i, j)
      Next
Next
With Worksheets.Add(before:=Sheet1)
      .Name = "99999"
      .Visible = -1
      .Range("a1").Resize(UBound(crr, 1), UBound(crr, 2)) = crr
      Set rng = .UsedRange
End With
Dim cl%, key, Keys, It
Dim dic
Set dic = CreateObject("scripting.dictionary")
Dim r1 As Range, r2 As Range
arr = rng
cl = UBound(arr, 2)
For i = 2 To UBound(arr, 1)
      key = arr(i, 1)
      Set r1 = rng.Cells(i, 1).Resize(1, cl)
      If Not dic.exists(key) Then
         Set dic(key) = r1
      Else
         Set dic(key) = Union(dic(key), r1)
      End If
Next
Set r2 = rng.Cells(1, 1).Resize(1, cl)
Keys = dic.Keys
It = dic.items
For i = 0 To dic.Count - 1
      With Worksheets.Add(after:=Sheets(Sheets.Count))
         .Name = Keys(i)
         r2.Copy .Cells(1, 1)
         It(i).Copy .Cells(2, 1)
      End With
Next
Worksheets("99999").Delete
Set dic = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

zqlpop308 · 发表于 2020-1-14 16:36

excel海发表于 2020-1-12 13:27
前面的班级考场分布已写好,后面的也差不多,你自己改下吧
Sub test()
Application.ScreenUpdating = F ...

谢谢你，现在最大的难度在于后面的考场要按考场+座位号排列做不出来。不过还是谢谢你

excel海 · 发表于 2020-1-14 17:57

zqlpop308 发表于 2020-1-14 16:36
谢谢你，现在最大的难度在于后面的考场要按考场+座位号排列做不出来。不过还是谢谢你

前面的代码会了，后面的也没问题

chxw68 · 发表于 2020-1-14 20:43

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Dim reg As New RegExp
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
With reg
.Global = False
.Pattern = "^[\u4e00-\u9fbc]+\s+(\d+)考场(\d+)号座$"
End With
With Worksheets("sheet1")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
arr = .Range("a1").Resize(r, c)
For j = 16 To UBound(arr, 2)
m = 0
ReDim brr(1 To UBound(arr), 1 To 6)
For i = 2 To UBound(arr)
If Len(arr(i, j)) <> 0 Then
Set mh = reg.Execute(arr(i, j))
m = m + 1
For k = 1 To 3
brr(m, k) = arr(i, k)
Next
brr(m, 4) = arr(i, j)
If mh.Count > 0 Then
brr(m, 5) = Val(mh(0).SubMatches(0))
brr(m, 6) = Val(mh(0).SubMatches(1))
End If
End If
Next
d(arr(1, j)) = brr
Next
End With
For Each aa In d.keys
brr = d(aa)
On Error Resume Next
Set ws = Worksheets(aa)
If Err Then
Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
ws.Name = aa
End If
On Error GoTo 0
With ws
With .Range("a1")
.Value = "2019-1期末考场安排汇总"
With .Font
.Size = 16
.Name = "微软雅黑"
End With
.Resize(1, 6).Merge
End With
.Range("a2:f2") = Array("行政班", "学号", "姓名", aa, "考场号", "座号")
.Range("a3").Resize(UBound(brr), UBound(brr, 2)) = brr
r = .Cells(.Rows.Count, 3).End(xlUp).Row
.Range("a3:f" & r).Sort key1:=.Range("e3"), Order1:=xlAscending, key2:=.Range("f3"), Order2:=xlAscending, Header:=xlNo
With .Range("a2:f" & r)
.Borders.LineStyle = xlContinuous
With .Font
.Size = 10
.Name = "微软雅黑"
End With
End With
.Columns("a:f").AutoFit
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
Next
End Sub

复制代码

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

考场表格拆分，求大神解决

评分

最新热点 /1