excel - 导出多张 VBA

Question

我正在处理我的 Excel 文件中的宏。我想将六个工作表导出为新的备份文件。有几张我也不想导出。当我现在运行代码时，有一张/两张正在导出，而其余四张没有导出。两个导出的工作表在另存为新文件后也会被关闭。我希望有人能够帮助我并给我建议和反馈。提前致谢。

我的代码是：

'''


 Sub SplitWorkbook2()

Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim xNWb As Workbook
Dim FolderName As String


    Application.ScreenUpdating = False
    Set xWb = Application.ThisWorkbook
    
        DateString = Format(Now, "mm-dd hh-mm")
        FolderName = "I:\Export\Backup\TEMPS\2021\Urenlijsten\" & " Werkbriefjes week " & Range("C4") & " " & DateString
    
MkDir FolderName

    Application.DisplayAlerts = False
    
On Error GoTo NErro

DoNotInclude = "Actions" & "Adressbook" & "Import" & "Hours_Database"
FileExtStr = ".xls"

For Each xWs In xWb.Sheets
        If InStr(DoNotInclude, xWs.Name) = 0 Then
            xWs.Copy
            Set xNWb = Application.Workbooks.Item(Application.Workbooks.Count)
                With xNWb
                    ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value
                    xFile = FolderName & "\" & Range("C6") & FileExtStr
                    xNWb.SaveAs xFile, FileFormat:=xlOpenXMLWorkbook
                End With
    
        End If

    Next xWs
   
    

NErro: xWb.Activate
    

xWb.Activate
 
Application.DisplayAlerts = True
Application.ScreenUpdating = True
    
    MsgBox "You can find the files in " & FolderName
   
    
End Sub

标签： excelvbaexport

Answer 1

导出工作表

• 未测试。

Option Explicit

Sub SplitWorkbook2()

    Dim wb As Workbook
    Dim ws As Worksheet
    Dim DoNotInclude As Variant
    Dim FileFormatNum As Long
    Dim FileExtStr As String
    Dim FolderName As String

    FolderName = "I:\Export\Backup\TEMPS\2021\Urenlijsten\" & " Werkbriefjes week " & Range("C4") & " " & DateString
    FileExtStr = ".xlsx" ' ??? not '.xls'
    DateString = Format(Now, "mm-dd hh-mm")
    
    DoNotInclude = Array("Actions" & "Adressbook" & "Import" & "Hours_Database")
    
    On Error Resume Next
    MkDir FolderName
    On Error GoTo 0
    
    Set wb = ThisWorkbook
    
    Application.ScreenUpdating = False
    
    For Each ws In wb.Worksheets
        If IsError(Application.Match(ws.Name, DoNotInclude, 0)) Then
            ws.Copy
            With ActiveWorkbook.Worksheets(1)
                .UsedRange.Value = .UsedRange.Value
                xFile = FolderName & "\" & .Range("C6") & FileExtStr
                Application.DisplayAlerts = False
                .Parent.SaveAs xFile, FileFormat:=xlOpenXMLWorkbook
                .Parent.Close
                Application.DisplayAlerts = True
            End With
        End If
    Next ws
   
    Application.ScreenUpdating = True
    
    MsgBox "You can find the files in " & FolderName
    'wb.FollowHyperlink FolderName ' open in Windows File Explorer
    
End Sub