[已解决]将不同班的内容输出为以班名为文件名的工作薄

yabifdp

 

请教：
如何做一个宏，将不同班的内容输出为以班名为文件名的工作薄，如与高一10班的相关的所有行，放入名为高一10班的工作薄中，谢谢！

rHL0Tjzi.rar (20.18 KB, 下载次数: 20)

2010-2-8 10:29 上传

点击文件名下载附件
将不同班的内容输出为以班名为文件名的工作薄

最佳答案

月排行榜 / 总排行榜

amulee

2010-2-8 11:11

楼主试试看

Sub 分拆()
    Dim ArrYS, MySht As Worksheet, i&
    Dim ZD As Integer
    Dim bkNew As Workbook
    Dim bkOld As Workbook
    Dim strTemp As String
    Dim d As Object
    Set bkOld = ThisWorkbook
    Set d = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    ArrYS = Sheets("成绩单").Range("A2:N" & Sheets("成绩单").[A65536].End(xlUp).Row)
    ZD = 4
    '拆分工作表
    For i = 1 To UBound(ArrYS, 1)
        If Not d.exists(ArrYS(i, ZD)) Then
            d(ArrYS(i, ZD)) = i
            ThisWorkbook.Sheets.Add.Name = ArrYS(i, ZD)
            Sheets("成绩单").Range("A1:N1").Copy
            Sheets(ArrYS(i, ZD)).Range("A1").PasteSpecial
        End If
        Sheets("成绩单").Range("A" & (i + 1) & ":N" & (i + 1)).Copy
        Sheets(ArrYS(i, ZD)).Range("A" & (Sheets(ArrYS(i, ZD)).Range("a65536").End(xlUp).Row + 1)).PasteSpecial
    Next i
    '保存工作簿
    For Each MySht In bkOld.Worksheets
        If MySht.Name <> "成绩单" And d.exists(MySht.Name) Then
            strTemp = MySht.Name
            Set bkNew = Workbooks.Add
            MySht.Move before:=bkNew.Sheets(1)
            bkNew.SaveAs Filename:=bkOld.Path & "\" & strTemp & ".xls"
            bkNew.Close False
        End If
    Next
    Application.ScreenUpdating = True
End Sub

跳转到最佳答案楼层

amulee

楼主试试看

Sub 分拆()
    Dim ArrYS, MySht As Worksheet, i&
    Dim ZD As Integer
    Dim bkNew As Workbook
    Dim bkOld As Workbook
    Dim strTemp As String
    Dim d As Object
    Set bkOld = ThisWorkbook
    Set d = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    ArrYS = Sheets("成绩单").Range("A2:N" & Sheets("成绩单").[A65536].End(xlUp).Row)
    ZD = 4
    '拆分工作表
    For i = 1 To UBound(ArrYS, 1)
        If Not d.exists(ArrYS(i, ZD)) Then
            d(ArrYS(i, ZD)) = i
            ThisWorkbook.Sheets.Add.Name = ArrYS(i, ZD)
            Sheets("成绩单").Range("A1:N1").Copy
            Sheets(ArrYS(i, ZD)).Range("A1").PasteSpecial
        End If
        Sheets("成绩单").Range("A" & (i + 1) & ":N" & (i + 1)).Copy
        Sheets(ArrYS(i, ZD)).Range("A" & (Sheets(ArrYS(i, ZD)).Range("a65536").End(xlUp).Row + 1)).PasteSpecial
    Next i
    '保存工作簿
    For Each MySht In bkOld.Worksheets
        If MySht.Name <> "成绩单" And d.exists(MySht.Name) Then
            strTemp = MySht.Name
            Set bkNew = Workbooks.Add
            MySht.Move before:=bkNew.Sheets(1)
            bkNew.SaveAs Filename:=bkOld.Path & "\" & strTemp & ".xls"
            bkNew.Close False
        End If
    Next
    Application.ScreenUpdating = True
End Sub

yabifdp

谢谢版主，谢谢！

chinaeu

amulee 哥们你很牛啊

coco_lin

膜拜amulee