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

改进说明:以前的时候太依赖于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

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