如何用VBA将EXCEL的每个worksheet保存成文件

《维基教科书.法语》(French from wikibooks)[PDF] 【转自mocchacumt】 »

2010-4

如何用VBA将EXCEL的每个worksheet保存成文件

你可能也对这些感兴趣

点我收起

不知道我在干什么。寄人篱下说一起学习，结果无所事事了一个月。一个小VBA的projet拖了这么久，内疚死。心态过于放松就是这样，硬是要在最后dead line才去学VBA。不过VBA真的很简单，projet是做一个简单的交互UserForm，但我自己想把一个sheet存成文件的时候SaveAs总是用不好，笨死我了。主要还是对语言不熟。下面的宏可以把每个worksheet另存为文件，比较完美了。大家慢慢举一反三。
那么从今天起简历上写的VBA不会太让我紧张了。这个语言在银行里很有用，但就那么回事。
这里有个学习EXCEL和VBA的教程，英语的，最多一个星期就可以无师自通了吧。
戳我吧，呵呵。。。。。

另外送一个VBA在金融领域的应用的网站

Sub Copy_Every_Sheet_To_New_Workbook()
'Working in 97-2007
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
 
    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ThisWorkbook
 
    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = Sourcewb.Path &amp; "\" &amp; Sourcewb.Name &amp; " " &amp; DateString
    MkDir FolderName
 
    'Copy every visible sheet to a new workbook
    For Each sh In Sourcewb.Worksheets
 
        'If the sheet is visible then copy it to a new workbook
        If sh.Visible = -1 Then
            sh.Copy
 
            'Set Destwb to the new workbook
            Set Destwb = ActiveWorkbook
 
            'Determine the Excel version and file extension/format
            With Destwb
                If Val(Application.Version) &lt; 12 Then
                    'You use Excel 97-2003
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    'You use Excel 2007
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        Select Case Sourcewb.FileFormat
                        Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                        Case 52:
                            If .HasVBProject Then
                                FileExtStr = ".xlsm": FileFormatNum = 52
                            Else
                                FileExtStr = ".xlsx": FileFormatNum = 51
                            End If
                        Case 56: FileExtStr = ".xls": FileFormatNum = 56
                        Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
                        End Select
                    End If
                End If
            End With
 
            'Change all cells in the worksheet to values if you want
            If Destwb.Sheets(1).ProtectContents = False Then
                With Destwb.Sheets(1).UsedRange
                    .Cells.Copy
                    .Cells.PasteSpecial xlPasteValues
                    .Cells(1).Select
                End With
                Application.CutCopyMode = False
            End If
 
            'Save the new workbook and close it
            With Destwb
                .SaveAs FolderName _
                      &amp; "\" &amp; Destwb.Sheets(1).Name &amp; FileExtStr, _
                        FileFormat:=FileFormatNum
                .Close False
            End With
 
        End If
GoToNextSheet:
    Next sh
 
    MsgBox "You can find the files in " &amp; FolderName
 
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
 
    End With
End Sub