[已解决]生成的审批表求差代码 怎么写

hhxq001

根据模板生成审批表，其中增资数因为花名册没有直接列出，需要在生成审批表时，算出来，
我不知道怎么算新旧标准只差（2数相减）。请大侠出手。
（审批表模板中黄色的部分）

复件 晋级审批表-批量生成-求和代码.zip (103.29 KB, 下载次数: 9)

2014-7-30 17:50 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

过江龙

2014-7-30 19:13

试试，红色部分为增加代码。
Private Sub 多人一表_Click()
   Dim n, mZren             'n为要定义的每表含的人数
   Dim arr, i%
    Application.ScreenUpdating = False
    With Sheets("花名册-数据源-勿删")
        arr = .Range("a5", .Cells(.Cells(.Rows.Count, 1).End(3).Row, "ad"))  '从a5开始提取数据，到ad列结束
        mZren = .Range("b65536").End(xlUp).Row - 2
    End With
   
    On Error Resume Next
    Application.DisplayAlerts = False
    n = InputBox("请选择几个人在一张表,当前总人数为" & mZren & "人", "输入人数", 0)   '选择人数提示窗口
   
   If UBound(arr) Mod n <> 0 Then        '定义每个工作表含n个人
   ssa = UBound(arr) \ n + 1
   Else
   ssa = UBound(arr) \ n
   
   End If
   For ii = 1 To ssa
   xxx = 0
   If ii = ssa Then xxx = n * ssa - UBound(arr)
   
    Sheets("新表=" & ii).Delete           '发现已存在带"新表="关键字的表删除
   
    Application.DisplayAlerts = True
    Sheets("审批表模板-勿删").Copy After:=Sheets(Sheets.Count)
    Set SH = ActiveSheet
   
    If n = 1 Then                    '如果n=1人
    SH.Name = "新表=" & arr(ii, 2)   '那么新生成的工作表名称为"新表=+姓名"
   
    Else
    SH.Name = "新表=" & ii           'n不等于1，则生成的新表为"新表=+编号"
    End If
    Set mcopy = SH.Rows("1:28")     '复制模板的1至28行
    For i = n * ii - xxx To 1 + n * (ii - 1) Step -1   '每个工作表满n人后，生成下一工作表
        With SH
            .Range("c3") = arr(i, 2)                   '新表单元格数据与数据源单元格对应
            .Range("i3") = arr(i, 3)
            .Range("m3") = arr(i, 4)
            .Range("s3") = arr(i, 10)
            .Range("c4") = arr(i, 13)
            .Range("m4") = arr(i, 21)
            .Range("s4") = arr(i, 30)
            .Range("c5") = arr(i, 5)
            .Range("m5") = arr(i, 29)
            .Range("c8") = arr(i, 13)
            .Range("f8") = arr(i, 14)
            .Range("m8") = arr(i, 16)
            .Range("p8") = arr(i, 17)
            .Range("r8") = arr(i, 18)
            .Range("v8") = arr(i, 12)
            
            .Range("c9") = arr(i, 21)
            .Range("f9") = arr(i, 22)
            .Range("m9") = arr(i, 24)
            .Range("p9") = arr(i, 25)
            .Range("r9") = arr(i, 26)
            .Range("v9") = arr(i, 20)
            
            .Range("p10") = arr(i, 25 - 14)
            .Range("r10") = arr(i, 11)
            .Range("v10") = arr(i, 28)
            
            .Range("b16") = arr(i, 14)
            .Range("a17") = arr(i, 22)
            
            .Range("d18") = arr(i, 17)
            .Range("b19") = arr(i, 25)
            
            .Range("e20") = arr(i, 18)
            .Range("b21") = arr(i, 26)
            .Range("b22") = arr(i, 28)
            .Cells(10, 16) = .Cells(9, 16) - .Cells(8, 16)
            .Cells(10, 18) = .Cells(9, 18) - .Cells(8, 18)
            
            
            
            If i <> 1 + n * (ii - 1) Then            'n个人
                mcopy.Copy
                .Rows("1:1").Insert
            End If
        End With
    Next
    SH.PageSetup.PrintArea = "$A$1:$v$" & SH.Range("A65536").End(xlUp).Row + 1  '打印范围a1:v1至所有有数据的行
   
   Next ii
   
     Application.ScreenUpdating = True
     
     MsgBox "生成完毕！"
   
   End Sub

跳转到最佳答案楼层

过江龙

试试，红色部分为增加代码。
Private Sub 多人一表_Click()
   Dim n, mZren             'n为要定义的每表含的人数
   Dim arr, i%
    Application.ScreenUpdating = False
    With Sheets("花名册-数据源-勿删")
        arr = .Range("a5", .Cells(.Cells(.Rows.Count, 1).End(3).Row, "ad"))  '从a5开始提取数据，到ad列结束
        mZren = .Range("b65536").End(xlUp).Row - 2
    End With
   
    On Error Resume Next
    Application.DisplayAlerts = False
    n = InputBox("请选择几个人在一张表,当前总人数为" & mZren & "人", "输入人数", 0)   '选择人数提示窗口
   
   If UBound(arr) Mod n <> 0 Then        '定义每个工作表含n个人
   ssa = UBound(arr) \ n + 1
   Else
   ssa = UBound(arr) \ n
   
   End If
   For ii = 1 To ssa
   xxx = 0
   If ii = ssa Then xxx = n * ssa - UBound(arr)
   
    Sheets("新表=" & ii).Delete           '发现已存在带"新表="关键字的表删除
   
    Application.DisplayAlerts = True
    Sheets("审批表模板-勿删").Copy After:=Sheets(Sheets.Count)
    Set SH = ActiveSheet
   
    If n = 1 Then                    '如果n=1人
    SH.Name = "新表=" & arr(ii, 2)   '那么新生成的工作表名称为"新表=+姓名"
   
    Else
    SH.Name = "新表=" & ii           'n不等于1，则生成的新表为"新表=+编号"
    End If
    Set mcopy = SH.Rows("1:28")     '复制模板的1至28行
    For i = n * ii - xxx To 1 + n * (ii - 1) Step -1   '每个工作表满n人后，生成下一工作表
        With SH
            .Range("c3") = arr(i, 2)                   '新表单元格数据与数据源单元格对应
            .Range("i3") = arr(i, 3)
            .Range("m3") = arr(i, 4)
            .Range("s3") = arr(i, 10)
            .Range("c4") = arr(i, 13)
            .Range("m4") = arr(i, 21)
            .Range("s4") = arr(i, 30)
            .Range("c5") = arr(i, 5)
            .Range("m5") = arr(i, 29)
            .Range("c8") = arr(i, 13)
            .Range("f8") = arr(i, 14)
            .Range("m8") = arr(i, 16)
            .Range("p8") = arr(i, 17)
            .Range("r8") = arr(i, 18)
            .Range("v8") = arr(i, 12)
            
            .Range("c9") = arr(i, 21)
            .Range("f9") = arr(i, 22)
            .Range("m9") = arr(i, 24)
            .Range("p9") = arr(i, 25)
            .Range("r9") = arr(i, 26)
            .Range("v9") = arr(i, 20)
            
            .Range("p10") = arr(i, 25 - 14)
            .Range("r10") = arr(i, 11)
            .Range("v10") = arr(i, 28)
            
            .Range("b16") = arr(i, 14)
            .Range("a17") = arr(i, 22)
            
            .Range("d18") = arr(i, 17)
            .Range("b19") = arr(i, 25)
            
            .Range("e20") = arr(i, 18)
            .Range("b21") = arr(i, 26)
            .Range("b22") = arr(i, 28)
            .Cells(10, 16) = .Cells(9, 16) - .Cells(8, 16)
            .Cells(10, 18) = .Cells(9, 18) - .Cells(8, 18)
            
            
            
            If i <> 1 + n * (ii - 1) Then            'n个人
                mcopy.Copy
                .Rows("1:1").Insert
            End If
        End With
    Next
    SH.PageSetup.PrintArea = "$A$1:$v$" & SH.Range("A65536").End(xlUp).Row + 1  '打印范围a1:v1至所有有数据的行
   
   Next ii
   
     Application.ScreenUpdating = True
     
     MsgBox "生成完毕！"
   
   End Sub

hhxq001

不错不错，谢谢