Страницы: 1
RSS
Не работает макрос UTF 8
 
Поставил более новую версию эксель и макрос перестал выполняться. Сразу вылетает ошибка и эксель закрывается.
Макрос внизу.
В чем проблема?
Код
Option Explicit

Const strDelimiter = """"
Const strDelimiterEscaped = strDelimiter & strDelimiter
Const strSeparator = ";"
Const strRowEnd = vbCrLf
Const strCharset = "utf-8"

Function CsvFormatString(strRaw As String) As String

    Dim boolNeedsDelimiting As Boolean

    boolNeedsDelimiting = InStr(1, strRaw, strDelimiter) > 0 _
        Or InStr(1, strRaw, Chr(10)) > 0 _
        Or InStr(1, strRaw, strSeparator) > 0

    CsvFormatString = strRaw

    If boolNeedsDelimiting Then
        CsvFormatString = strDelimiter & _
            Replace(strRaw, strDelimiter, strDelimiterEscaped) & _
            strDelimiter
    End If

End Function

Function CsvFormatRow(rngRow As Range) As String

    Dim arrCsvRow() As String
    ReDim arrCsvRow(rngRow.Cells.Count - 1)
    Dim rngCell As Range
    Dim lngIndex As Long

    lngIndex = 0

    For Each rngCell In rngRow.Cells
        arrCsvRow(lngIndex) = CsvFormatString(rngCell.Text)
        lngIndex = lngIndex + 1
    Next rngCell


    CsvFormatRow = Join(arrCsvRow, ";") & strRowEnd

End Function

Sub CsvExportRange( _
        rngRange As Range, _
        Optional strFileName As Variant _
    )

    Dim rngRow As Range
    Dim objStream As Object

    If IsMissing(strFileName) Or IsEmpty(strFileName) Then
        strFileName = Application.GetSaveAsFilename( _
            InitialFileName:=ActiveWorkbook.Path & "\" & rngRange.Worksheet.Name & ".csv", _
            FileFilter:="CSV (*.csv), *.csv", _
            Title:="Export CSV")
    End If

    Set objStream = CreateObject("ADODB.Stream")
    objStream.Type = 2
    objStream.Charset = strCharset
    objStream.Open

    For Each rngRow In rngRange.Rows
        objStream.WriteText CsvFormatRow(rngRow)
    Next rngRow

    objStream.SaveToFile strFileName, 2
    objStream.Close


End Sub

Sub CsvExportSelection()
    CsvExportRange ActiveWindow.Selection
    MsgBox "CSV file, with selected range is ready."
End Sub

Sub CsvExportSheet()

    Dim wksSheet As Worksheet
    Set wksSheet = ActiveSheet

    CsvExportRange wksSheet.UsedRange
    MsgBox "CSV file, with active sheet is ready."

End Sub
 
Всё нормально с макросом
Если Excel вылетает - проблема в нём (неудачная версия)

скорее всего, ошибку даёт Application.GetSaveAsFilename
(неверный FileFilter, или недоступный путь InitialFileName)
попробуйте поменять параметры вызова этой функции, или используйте другую функцию для получения имени файла

у меня как-то такая же проблема была с этой функцией, Excel вылетал
но проблема проявлялась на 1 компе из 10-20
Если только на вашем компе проблема, - попробуйте установить другую версию Office
 
А не можете подсказать какие варианты попробовать?
Я пробую - но пока ничего не получается(
 
Вот что пишет ошибка

Описание:
Stopped working
Сигнатура проблемы:
Скрытый текст
Страницы: 1
Читают тему
Наверх