[已解决]新生成的工作表按人数命名怎么写代码

hhxq001

想要批量生成的工作表按照每表的人数命名，怎么写代码？

比如，生成的表每表5人，工作表名称就是“新表=1-5、新表=6-10、新表=11-14”

复件 晋档个人审批表-宏批量生成=新表命名.zip (99.37 KB, 下载次数: 6)

2014-7-31 20:50 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

过江龙

2014-7-31 21:59

试试，顺便提醒一下，把问题一次性的提完，便于综合考虑
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 - 4
    End With
   
    On Error Resume Next
    Application.DisplayAlerts = False
    n = InputBox("请选择几个人在一张表,当前总人数为" & mZren & "人。", "输入人数", 50)   '选择人数提示窗口
   
   If UBound(arr) Mod n <> 0 Then        '定义每个工作表含n个人
   ssa = UBound(arr) \ n + 1
   Else
   ssa = UBound(arr) \ n
   
   End If
   
  k = 1
   k1 = n
   For ii = 1 To ssa
   xxx = 0
   If ii = ssa Then
   xxx = n * ssa - UBound(arr)
   k1 = mZren
   End If
    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 = "新表=" & k & "-" & k1           'n不等于1，则生成的新表为"新表=+编号"
    k = k + n
    k1 = k + 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("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)
            
            .Cells(10, 16) = .Cells(9, 16) - .Cells(8, 16)  '计算新表的增资数 (p,10)=(p,9)-(p,8)
            .Cells(10, 18) = .Cells(9, 18) - .Cells(8, 18)  '计算新表的增资数 (r,10)=(r,9)-(r,8)
            
            .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)
            
                        
            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 - 4
    End With
   
    On Error Resume Next
    Application.DisplayAlerts = False
    n = InputBox("请选择几个人在一张表,当前总人数为" & mZren & "人。", "输入人数", 50)   '选择人数提示窗口
   
   If UBound(arr) Mod n <> 0 Then        '定义每个工作表含n个人
   ssa = UBound(arr) \ n + 1
   Else
   ssa = UBound(arr) \ n
   
   End If
   
  k = 1
   k1 = n
   For ii = 1 To ssa
   xxx = 0
   If ii = ssa Then
   xxx = n * ssa - UBound(arr)
   k1 = mZren
   End If
    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 = "新表=" & k & "-" & k1           'n不等于1，则生成的新表为"新表=+编号"
    k = k + n
    k1 = k + 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("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)
            
            .Cells(10, 16) = .Cells(9, 16) - .Cells(8, 16)  '计算新表的增资数 (p,10)=(p,9)-(p,8)
            .Cells(10, 18) = .Cells(9, 18) - .Cells(8, 18)  '计算新表的增资数 (r,10)=(r,9)-(r,8)
            
            .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)
            
                        
            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

过江龙 发表于 2014-7-31 21:59
试试，顺便提醒一下，把问题一次性的提完，便于综合考虑
Private Sub 多人一表_Click()
   D ...

谢谢帮忙。我都是在完成某一功能后想到，这样行不行。。。
总之是不断学习中想到的呢