求助各位老师如果根据“试室号”“座位号”来分别像现在的函数那样来生成黄色...

qinhuan66

求助各位老师如果根据数据库D列“试室号”；E列“座位号”来分别像现在的函数那样来生成黄色区域的考试座位安排表（以下每张表一样）    谢谢   
准考证原始数据.rar (95.62 KB, 下载次数: 13)

2013-1-14 10:56 上传

点击文件名下载附件

suye1010

1. Option Explicit
   
2. 
   
3. Sub GenPosArr()
   
4. Dim i As Integer, j As Integer, RoomNo As Integer, RowsInRoom As Integer, PeopleInRoom As Integer, arr0, arr
   
5. arr0 = Sheets("数据库").UsedRange
   
6. ReDim arr(1 To UBound(arr0), 1 To 19)
   
7. For i = 3 To UBound(arr0)
   
8. If arr0(i, 1) <> "" Then
   
9.     PeopleInRoom = Application.WorksheetFunction.CountIf(Sheets("数据库").Range("D3:D65535"), arr0(i, 4))
   
10.     RowsInRoom = IIf(PeopleInRoom Mod 5, PeopleInRoom \ 5 + 1, PeopleInRoom \ 5)
    
11.     arr(arr0(i, 4) * 17 - 16, 4) = arr0(i, 10)
    
12.     arr(arr0(i, 4) * 17 - 16, 16) = "第" & Replace(Application.WorksheetFunction.Text(arr0(i, 4), "[DBNum1][$-804]General"), "一十", "十") & "试室"
    
13.     arr(arr0(i, 4) * 17 - 14, 9) = "讲台"
    
14.     For j = 1 To PeopleInRoom
    
15.         arr((arr0(i, 4) - 1) * 17 + IIf(((j - 1) \ RowsInRoom) Mod 2, RowsInRoom * 2 + 3 - ((j - 1) Mod RowsInRoom) * 2, ((j - 1) Mod RowsInRoom) * 2 + 5), _
    
16.             ((j - 1) \ RowsInRoom) * 4 + 3) = Format(j, "00")
    
17.         arr((arr0(i, 4) - 1) * 17 + IIf(((j - 1) \ RowsInRoom) Mod 2, RowsInRoom * 2 + 3 - ((j - 1) Mod RowsInRoom) * 2, ((j - 1) Mod RowsInRoom) * 2 + 5), _
    
18.             ((j - 1) \ RowsInRoom) * 4 + 2) = arr0(i + j - 1, 6)
    
19.         arr((arr0(i, 4) - 1) * 17 + IIf(((j - 1) \ RowsInRoom) Mod 2, RowsInRoom * 2 + 3 - ((j - 1) Mod RowsInRoom) * 2, ((j - 1) Mod RowsInRoom) * 2 + 5), _
    
20.             ((j - 1) \ RowsInRoom) * 4 + 1) = "准考证号"
    
21.         arr((arr0(i, 4) - 1) * 17 + IIf(((j - 1) \ RowsInRoom) Mod 2, RowsInRoom * 2 + 4 - ((j - 1) Mod RowsInRoom) * 2, ((j - 1) Mod RowsInRoom) * 2 + 6), _
    
22.             ((j - 1) \ RowsInRoom) * 4 + 2) = arr0(i + j - 1, 1)
    
23.         arr((arr0(i, 4) - 1) * 17 + IIf(((j - 1) \ RowsInRoom) Mod 2, RowsInRoom * 2 + 4 - ((j - 1) Mod RowsInRoom) * 2, ((j - 1) Mod RowsInRoom) * 2 + 6), _
    
24.             ((j - 1) \ RowsInRoom) * 4 + 1) = "姓名"
    
25.     Next j
    
26.     i = i + Application.WorksheetFunction.CountIf(Sheets("数据库").Range("D3:D1000"), arr0(i, 4)) - 1
    
27. End If
    
28. Next i
    
29. Sheets("试室安排").Range("A1").Resize(UBound(arr, 1), 19) = arr
    
30. End Sub

复制代码

准考证原始数据.zip (76.42 KB, 下载次数: 4, 售价: 5 个金币)

2013-1-15 18:17 上传

点击文件名下载附件

qinhuan66

suye1010 发表于 2013-1-14 18:10

arr(arr0(i, 4) * 17 - 16, 16) = "第" & Application.WorksheetFunction.Text(arr0(i, 4), "[DBNum1][$-804]0") & "试室"

例如：第22试室
这里生成的第二二试室
能否换成第二十二试室

谢谢

qinhuan66

suye1010 发表于 2013-1-14 18:10

老师我有一个附件原本是可以生成出来的，但是现在有一个值生成不出来了，原因是我在原始表里改为设有公式求出，如果不用公式的表就可以提取过来，表达不清楚请看附件：


原始表J2改用公式求出，不用公式的话还是可以提取过去的



现在主要就是圈内的代码如何改为有公式的值也可以提取，因为所有的原始表格J2本人都改为设有公式


求助suye1010老师.rar (214.49 KB, 下载次数: 5)

2013-1-16 11:13 上传

点击文件名下载附件

suye1010

1. Sub 生成各参保单位托收数据()
   
2. Dim wj As String, fs As Object, arr
   
3. Application.ScreenUpdating = False
   
4. Application.DisplayAlerts = False
   
5. Application.EnableEvents = False
   
6. Range("a3:s500").ClearContents
   
7. wj = Dir(ThisWorkbook.Path & "\数据库")
   
8. s = 2
   
9. Do While wj <> ""
   
10.     If s = 2 Then
    
11.         ReDim arr(1 To 19, 1 To 1)
    
12.     Else
    
13.         ReDim Preserve arr(1 To 19, 1 To UBound(arr, 2) + 1)
    
14.     End If
    
15.     s = s + 1
    
16.     Set fs = GetObject(ThisWorkbook.Path & "\数据库" & wj)
    
17.     fs.Sheets(1).Calculate
    
18.     arr(1, s - 2) = s - 2
    
19.     arr(2, s - 2) = Mid(wj, 6, Len(wj) - 9)
    
20.     arr(3, s - 2) = fs.Sheets(1).[g2]
    
21.     arr(4, s - 2) = fs.Sheets(1).[n2]
    
22.     arr(5, s - 2) = Sheets(1).[j2]
    
23.     arr(6, s - 2) = Application.WorksheetFunction.CountIf(fs.Sheets(1).Range("u6:u1000"), "在职")
    
24.     arr(7, s - 2) = Application.WorksheetFunction.CountIf(fs.Sheets(1).Range("u6:u1000"), "退休")
    
25.     arr(8, s - 2) = Application.WorksheetFunction.CountIf(fs.Sheets(1).Range("u6:u1000"), "停缴")
    
26.     arr(9, s - 2) = Application.WorksheetFunction.SumIf(fs.Sheets(1).Range("u6:u1000"), "在职", fs.Sheets(1).Range("r6:r1000"))
    
27.     arr(10, s - 2) = Application.WorksheetFunction.SumIf(fs.Sheets(1).Range("u6:u1000"), "在职", fs.Sheets(1).Range("r6:r1000")) * 0.18
    
28.     arr(11, s - 2) = Application.WorksheetFunction.SumIf(fs.Sheets(1).Range("u6:u1000"), "在职", fs.Sheets(1).Range("r6:r1000")) * 0.02
    
29.     arr(12, s - 2) = Application.WorksheetFunction.SumIf(fs.Sheets(1).Range("W6:W1000"), "托", fs.Sheets(1).Range("r6:r1000"))
    
30.     arr(13, s - 2) = "=""养老保险：缴费人数：""&SUM(RC[-7])&""人"""
    
31.     arr(14, s - 2) = _
    
32.     "=""单位缴存：""&TEXT(RC[-5],""0.00"")&""""&""×""&18%&""=""&TEXT(RC[-5]*18%,""0.00"")&"""""
    
33.     arr(15, s - 2) = _
    
34.     "=""个人缴存：""&TEXT(RC[-6],""0.00"")&""""&""×""&2%&""=""&TEXT(RC[-6]*2%,""0.00"")&"""""
    
35.     arr(16, s - 2) = _
    
36.     "=""返纳金：""&TEXT(RC[-4],""0.00"")&""""&""×""&18%&""=""&TEXT(RC[-4]*18%,""0.00"")&"""""
    
37.     arr(17, s - 2) = Application.WorksheetFunction.SumIf(fs.Sheets(1).Range("W6:W1000"), "托", fs.Sheets(1).Range("r6:r1000")) * 0.18
    
38.     arr(18, s - 2) = "=VLOOKUP(R1C4,年度月份设置!R2C3:R13C4,2,0)"
    
39.     arr(19, s - 2) = "=SUM(RC[-9]+RC[-8]+RC[-2])"
    
40.     fs.Close False
    
41.     wj = Dir
    
42. Loop
    
43. Cells(3, 1).Resize(UBound(arr, 2), UBound(arr)) = Application.Transpose(arr)
    
44. Application.EnableEvents = True
    
45. Application.DisplayAlerts = True
    
46. Application.ScreenUpdating = True
    
47. End Sub

复制代码

qinhuan66

qinhuan66 发表于 2013-1-15 17:30
arr(arr0(i, 4) * 17 - 16, 16) = "第" & Application.WorksheetFunction.Text(arr0(i, 4), "[DBNum1][$- ...

老师您好为什么D列没有试室号生成会出错呢?能否D列没值时不弹出错误。谢谢

dwq03sx

好东西，谢谢分享