Excel-Datei im gleichen Verzeichnis ohne Bestätigung speichern

Sub CSVFile_UTF8WithoutBOM()

  Const adTypeText = 2
  Const adModeReadWrite = 3
  Const adTypeBinary = 1
  Const adLF = 10
  Const adSaveCreateOverWrite = 2
  Const adWriteLine = 1

Dim SrcRange As Range
Dim CurrRow As Range
Dim CurrCell As Range
Dim CurrTextStr As String
Dim ListSep As String
Dim FName As Variant
Dim UTFStream As Object
Dim BinaryStream As Object

' ask for file name and path  
  FName = Application.GetSaveAsFilename("", "CSV File (*.csv), *.csv")  

' prepare UTF-8 stream  
  Set UTFStream = CreateObject("adodb.stream")  
  UTFStream.Type = adTypeText
  UTFStream.Mode = adModeReadWrite
  UTFStream.Charset = "UTF-8"  
  UTFStream.LineSeparator = adLF
  UTFStream.Open

  'set field separator  
  ListSep = ";"  
  'set source range with data for csv file  
  If Selection.Cells.Count > 1 Then
    Set SrcRange = Selection
  Else
    Set SrcRange = ActiveSheet.UsedRange
  End If
  
For Each CurrRow In SrcRange.Rows
    'enclose each value with quotation marks and escape quotation marks in values  
    CurrTextStr = ""  
    For Each CurrCell In CurrRow.Cells
      'CurrTextStr = CurrTextStr & """" & Replace(CurrCell.Value, """", """""") & """" & ListSep  
    
    CurrTextStr = CurrTextStr & "" & Replace(CurrCell.Value, "", """") & "" & ListSep  
   
    
    Next
    'remove ListSep after the last value in line  
    While Right(CurrTextStr, 1) = ListSep
      CurrTextStr = Left(CurrTextStr, Len(CurrTextStr) - 1)
    Wend
    'add line to UTFStream  
    UTFStream.WriteText CurrTextStr, adWriteLine
  Next

  'skip BOM  
  UTFStream.Position = 3

  'copy UTFStream to BinaryStream  
  Set BinaryStream = CreateObject("adodb.stream")  
  BinaryStream.Type = adTypeBinary
  BinaryStream.Mode = adModeReadWrite
  BinaryStream.Open

  'Strips BOM (first 3 bytes)  
  UTFStream.CopyTo BinaryStream

  UTFStream.Flush
  UTFStream.Close

  
  
  'save to file  
  BinaryStream.SaveToFile FName, adSaveCreateOverWrite
  BinaryStream.Flush
  BinaryStream.Close
  

End Sub