excel - 保存电子表格时删除特殊字符

问题描述

我找到了一个 VBA 代码。问题是我需要保存的列有特殊字符，因此 VBA 无法保存我的文件。
例如：虽然列 abcde... 有特定数据
Col Q 将有 John / Doe
由于特殊字符，此代码无法保存。
我希望 VBA 将 Q 列的过滤数据保存在路径中
“学分 Nov2019 John Doe”
Sub SplitToWorksheets()
Dim ColHead As String
Dim ColHeadCell As Range
Dim iCol As Integer
Dim iRow As Long 'row index on Fan Data sheet
Dim Lrow As Integer 'row index on individual destination sheet
Dim Dsheet As Worksheet 'destination worksheet
Dim Fsheet As Worksheet 'fan data worksheet (assumed active)
Again:
ColHead = InputBox("Enter Column Heading", "Identify Column", [c1].Value)
If ColHead = "" Then Exit Sub
Set ColHeadCell = Rows(1).Find(ColHead, LookAt:=xlWhole)
If ColHeadCell Is Nothing Then
    MsgBox "Heading not found in row 1"
    GoTo Again
End If
Set Fsheet = ActiveSheet
iCol = ColHeadCell.Column
'loop through values in selected column
For iRow = 2 To Fsheet.Cells(65536, iCol).End(xlUp).Row
    If Not SheetExists(CStr(Fsheet.Cells(iRow, iCol).Value)) Then
        Set Dsheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
        Dsheet.Name = CStr(Fsheet.Cells(iRow, iCol).Value)
        Fsheet.Rows(1).Copy Destination:=Dsheet.Rows(1)
    Else
        Set Dsheet = Worksheets(CStr(Fsheet.Cells(iRow, iCol).Value))
    End If
    Lrow = Dsheet.Cells(65536, iCol).End(xlUp).Row
    Fsheet.Rows(iRow).Copy Destination:=Dsheet.Rows(Lrow + 1)
Next iRow
End Sub

Function SheetExists(SheetId As Variant) As Boolean
' This function checks whether a sheet (can be a worksheet,
' chart sheet, dialog sheet, etc.) exists, and returns
' True if it exists, False otherwise. SheetId can be either
' a sheet name string or an integer number. For example:
' If SheetExists(3) Then Sheets(3).Delete
' deletes the third worksheet in the workbook, if it exists.
' Similarly,
' If SheetExists("Annual Budget") Then Sheets("Annual Budget").Delete
' deletes the sheet named "Annual Budget", if it exists.
Dim sh As Object
On Error GoTo NoSuch
Set sh = Sheets(SheetId)
SheetExists = True
Exit Function
NoSuch:
If Err = 9 Then SheetExists = False Else Stop
End Function

Sub Split_To_Workbook_and_Email()
'Working in 2013/2016
    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
    Dim myOutlook As Object
    Dim myMailItem As Object
    Dim mySubject As String
    Dim myPath As String
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    'Prompt for Email Subject

    Set otlApp = CreateObject("Outlook.Application")
    mySubject = InputBox("Subject for Email")

    'Copy every sheet from the workbook with this macro
    Set Sourcewb = ActiveWorkbook
    'Create new folder to save the new files in
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
    FolderName = "C:\Temp\" & Sourcewb.Name & " " & 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) < 12 Then
                    'You use Excel 97-2003
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    'You use Excel 2007-2016
                    If Sourcewb.Name = .Name Then
                        MsgBox "Your answer is NO in the security dialog"
                        GoTo GoToNextSheet
                    Else
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    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, email it, and close it
            Set otlNewMail = otlApp.CreateItem(olMailItem)
            With Destwb
                .SaveAs FolderName _
                      & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                        FileFormat:=FileFormatNum
            End With
            myPath = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name
            With Destwb
                .Close False
            End With
            With otlNewMail
                .Subject = mySubject
                .Body = " "
                .Attachments.Add myPath
                .Display
            End With

            Set otlNewMail = Nothing
        End If
GoToNextSheet:
    Next sh
    MsgBox "You can find the files in " & FolderName
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub
标签： excelvba
excel - 保存电子表格时删除特殊字符

问题描述

解决方案

推荐阅读
