[已解决]求助：功能增加（VBA）

long826121 · 发表于 2012-7-2 17:39

本帖最后由 long826121 于 2012-7-2 20:05 编辑

感谢兄弟姐妹们在百忙中抽出时间来帮我，非常感谢！
增加效果：创建各班的成绩单时，同时还创建“年级成绩单”，也就是说：同时创建“初一成绩单，初二成绩单，初三成绩单”（格式为：年级排名，班级，学号，姓名，性别，数学，语文，英语，物理，化学，生物，体育，总分），当班级减少时，再次点击“创建班级工作表”按钮时，原来创建多余的成绩表自动删除；当班级增多时，在此点击“创建班级工作表”按钮时，再创建没有成绩表的班级成绩单。
附件地址下面的附件代码需要修改！

1.rar (36.11 KB, 下载次数: 11)

zjdh · 发表于 2012-7-2 19:23

增加功能.rar (24.4 KB, 下载次数: 21)

zjdh · 发表于 2012-7-3 07:59

“班级管理窗口”中删除改为以下语句更好一些（可删除整个年级的所有工作表）
Private Sub 删除_Click()
Dim b As String
Dim i As Integer
Application.DisplayAlerts = False
On Error Resume Next
b = 选择年级.Text
With Sheets("班级管理")
For i = 1 To 3
      If .Cells(1, i) = b Then
         For Each Sh In Sheets
         If Sh.Name Like b & "*" Then Sh.Delete
         Next
         .Cells(2, i).Resize(65535, 1).ClearContents
         选择年级.Value = ""
         班数.Value = ""
         MsgBox "删除班级成功!", vbExclamation, "班级窗口温馨提示："
         Exit Sub
      End If
Next
End With
Application.DisplayAlerts = True
End Sub

long826121 · 发表于 2012-7-3 14:42

根据上楼代码的提示，加上自己的捉摸修改了下代码，基本上实现了这个功能，只不过还是与上面要求的有区别。希望能按原要求做出的兄弟们，给出一些建议。
上楼的代码与下面的代码结合基本能实现；仅参考
Private Sub 创建班级工作表_Click()
On Error Resume Next
Dim ws As Worksheet, sh As Worksheet
Dim i As Integer, j As Integer
For i = 1 To Worksheets.Count
If Worksheets(i).Name <> "首页" Then
   Worksheets(i).Visible = True
End If
Next i
For j = 1 To m
         Worksheets.Add after:=Worksheets(Worksheets.Count)
         ActiveSheet.Name = class(j) & "成绩单"
         Range("A1:M1").Select
         Selection = Array("年级排名", "班级", "学号", "姓名", "性别", "数学", "语文", "英语", "物理", "化学", "生物", "体育", "总分")
         Selection.HorizontAlignment = xlCenter
         Columns("A:A").NumberFormatLocal = "@"
      For i = 1 To n(j)
         Set ws = Worksheets(class(j) & Space(1) & class(j, i))
         If ws Is Nothing Then
            Worksheets.Add after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = class(j) & Space(1) & classname(j, i)
            Range("A1:M1").Select
            Selection = Array("班级排名", "年级排名", "学号", "姓名", "性别", "数学", "语文", "英语", "物理", "化学", "生物", "体育", "总分")
            Selection.HorizontAlignment = xlCenter
            Columns("A:A").NumberFormatLocal = "@"
         End If
      Next i
Next j
Application.DisplayAlerts = False
For Each ws In Worksheets
If ws.Name Like "Sheet*" Then
ws.Delete
End If
Next
Application.DisplayAlerts = True
Worksheets("首页").Activate
ActiveSheet.Range("A2").Select
End Sub

zjdh · 发表于 2012-7-3 15:09

回复2楼点评
这容易解决，添加一句语句：
Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
On Error Resume Next
For i = 1 To Sheets.Count
      If Sheets(i).Name = Node.Key Then
         Worksheets(Node.Key).Visible = True
         Worksheets(Node.Key).Activate
         GoTo 10
      End If
Next
BM = Node.Key
If Len(BM) = 2 Then Exit Sub
创建工作表
10  BM = Split(Node.Key, Space(1))(0) & "成绩单"
For i = 1 To Sheets.Count
      If Sheets(i).Name = BM Then Exit Sub
Next
创建工作表
End Sub

zjdh · 发表于 2012-7-3 15:12

本帖最后由 zjdh 于 2012-7-3 19:25 编辑

补发附件，修改了年级表列标内容：

增加功能2.rar (23.95 KB, 下载次数: 43)

long826121 · 发表于 2012-7-3 17:12

zjdh 发表于 2012-7-3 15:12
补发附件，修改了年级表列标内容：

首先非常感谢你及时回复！问题：运行时错误'9'，下标越界

zjdh · 发表于 2012-7-3 19:09

本帖最后由 zjdh 于 2012-7-3 19:24 编辑

long826121 发表于 2012-7-3 17:12
首先非常感谢你及时回复！问题：运行时错误'9'，下标越界

原因是你原来的宏有问题！当删除了所有的班级工作表时，调出窗口就下标越界了。
Public Sub 年级班级()
Dim i As Integer, j As Integer, nmax As Integer
Dim ws As Worksheet
Set ws = Worksheets("班级管理")
m = ws.Range("IV1").End(xlToLeft).Column
ReDim n(1 To m) As Integer
ReDim class(1 To m) As String
nmax = ws.UsedRange.Rows.Count ' - 1 没有班级时，出现了变量值为“0”！
ReDim classname(1 To m, 1 To nmax) As String
For j = 1 To m
      n(j) = ws.Cells(65536, j).End(xlUp).Row - 1
      class(j) = ws.Cells(1, j)
      For i = 1 To n(j)
         classname(j, i) = ws.Cells(1 + i, j)
      Next i
Next j
End Sub

6楼附件已更新

long826121 · 发表于 2012-7-3 21:48

zjdh 发表于 2012-7-3 19:09
原因是你原来的宏有问题！当删除了所有的班级工作表时，调出窗口就下标越界了。
Public Sub 年级班级( ...

真麻烦你了！非常感谢你哈！

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

[已解决]求助：功能增加（VBA）

点评

评分