关于按班号提取工作表的再次改进

改进说明:以前的时候太依赖于for循环,造成必对班号有特别要求,如果原始数据表不是连续的,还要先进行手动调整,一直感觉很别扭,虽然知道可以通过逐个单元格进行判断,但那样的话就对程序运行的过程无法做到掌控,所以一直处于抵触状态.今天通过看VBA的程序设计一书,完美的解决了这个问题,而且对循环的另两种表达形式:for each 和do while语句有了全新的认识,更重要的是对VBA中的对象概念有了初步的认识,第一次认识到VBA中的对象完全可以解决以前全过程性的程序设计.

今天这个程序是对按班号提取工作表进行改进,而且专门对班号的排列进行了混编,保证班号无序/班号不连续,这样就可以基本保证无法用for循环来实现提取.

闲话不说了,直接上源代码:

Option Explicit

Sub 将指定工作簿中的数据分班提取到不同工作簿中()
    '1:按工作簿中的班级号生成工作表(以班号为工作表标签)
    '2:处理完毕后,将各个班级工作表分至班级工作簿中
    '3:注意保存并退出
    '4:此程序最好的一点是即使是班号不连续,也可以一样按班提取,并且对班号的排列也
    '没有特殊要求了.
    Dim Sht As Worksheet, i As Integer
    
    '清除掉除成绩工作表外的所有其他工作表
    Application.DisplayAlerts = False
    For Each Sht In Worksheets
        If Sht.Name <> "成绩" Then
            Sht.Delete
        End If
    Next Sht
    Application.DisplayAlerts = True
    
    
    '按班级号生成工作表,并以班号为工作表标签
    Set Sht = Worksheets("成绩")
    i = 2
    Do While Sht.Cells(i, "A").Value <> ""
        On Error Resume Next
        If Worksheets("" & Sht.Cells(i, "A").Value & "") Is Nothing Then
            Worksheets.Add after:=Worksheets(Worksheets.Count)
            ActiveSheet.Name = Sht.Cells(i, "A").Value
            Worksheets("成绩").Rows(1).Copy ActiveSheet.Range("A1")
        End If
        i = i + 1
    Loop
    On Error GoTo 0  '如果没有这句话,程序好像陷入了死循环,最长时间一个下午还没有运行完!!
    
    '将成绩工作表中的每行数据复制到各班工作表中
    Worksheets("成绩").Activate
    Dim myRng As Range, bj As String '班级虽然实际上数值型,但由于需要用来作工作表的标签名,所以必须弄成字符串型.
    i = 2
    bj = Cells(i, "A").Value
    Do While bj <> ""
        Set myRng = Worksheets(bj).Range("A65536").End(xlUp).Offset(1, 0)
        Rows(i).Copy myRng 'myRng中已经包含单元格的绝对地址,所以会自动复制到相应工作表中的准确位置.
        'Range(Cells(i, 1), Cells(i, Range("IV256").End(xlToLeft).Column)).Copy myRng
        i = i + 1
        bj = Cells(i, "A").Value
    Loop
    
    '将列宽调整到合适的列宽
    For Each Sht In Worksheets
        Sht.Cells.Columns.AutoFit
    Next Sht
    
    '将班级工作表另存为工作簿
    Rem=首先需要建立一个文件夹用于存储班级成绩表
    Dim fileFolder As String
    fileFolder = ThisWorkbook.Path & "\班级成绩表"
    If Len(Dir(fileFolder, vbDirectory)) = 0 Then
        MkDir fileFolder
    Else
        If Len(Dir(fileFolder & "\*.*")) <> 0 Then
            Kill fileFolder & "\*.*"
        End If
    End If
    
    Rem=开始将工作表另存为相应的工作簿
    Application.DisplayAlerts = False
    For Each Sht In Worksheets
        If Sht.Name <> "成绩" Then
            Sht.Copy
            ActiveWorkbook.SaveAs fileFolder & "\" & Sht.Name & ".xls"
            ActiveWorkbook.Close savechanges:=True
            Sht.Delete
        End If
    Next Sht
    Application.DisplayAlerts = True
    Set Sht = Nothing
    
    
    
End Sub

下一篇文章将解决如何对工作表或工作进行合并至同一张表,有来有去嘛,光分不合也不行啊.