VBA Tabellenblatt speichern und wenn vorhanden neuer Name

[deschroe]

Hallo,

ich habe folgendenden VBA Code, mit dem ich Tabellenblätter abspeichern kann.

Code:

Sub LoeschenBestellblaetterundCSVspeichern()
 Dim wks As Worksheet
 Application.ScreenUpdating = False
 For Each wks In ThisWorkbook.Sheets
   If LCase(wks.Name) <> "bestellung" And _
     LCase(wks.Name) <> "bestand" And _
     LCase(wks.Name) <> "ek" Then
     wks.Copy
     ActiveWorkbook.SaveAs "S:\_Vertraege_ET_WIL\Bestelldatei\" & ActiveSheet.Name & " DS", xlCSV, Local:=True
     ActiveWorkbook.Close False
   End If
 Next wks
 Application.ScreenUpdating = True
 MsgBox "Dateien erfolgreich gespeichert"
End Sub

Nun kann es allerdings vorkommen, dass bereits eine Datei mit dem gleichen Namen an dem Speicherort vorhanden ist.
In diesem Fall soll die Datei natürlich nicht überschrieben werden, sondern nach der folgenden Logik abgespeichert werden. 

In einem anderen Forum, habe ich den folgenden Code gefunden:
http://www.office-loesung.de/ftopic412426_0_0_asc.php

Code:

Dateiname
Dateiname (1)
Dateiname (2)

In einem anderen Forum habe ich den folgenden Code gefunden:

Option Explicit

Sub x()
   Dim strFilename As String
   
   strFilename = getName("c:\temp\kw39", ".xls")
   MsgBox strFilename
End Sub

Private Function getName(ByVal strName As String, ByVal strExtension As String) As String
   Dim lngNummer As Long
   
   If Dir(strName & strExtension) = "" Then
      getName = strName & strExtension
   Else
      lngNummer = 1
      While Dir(strName & "_" & lngNummer & strExtension) <> ""
         lngNummer = lngNummer + 1
      Wend
      getName = strName & "_" & lngNummer & strExtension
   End If
End Function

Meine VBA Kentnisse reichen aber bei weitem nicht aus, um eine Verbindung bzw. Verknüpfung der beiden Codes herzustellen.


Möglicherweise habt ihr ja auch ganz andere Lösungsansätze.
Über jegliche Antwort wäre ich sehr dankbar.

[MisterBurns]

Ungetestet

Code:

Sub LoeschenBestellblaetterundCSVspeichern()
Dim wks As Worksheet, Datei As String, Pfad As String, Zaehler As Integer
Application.ScreenUpdating = False
For Each wks In ThisWorkbook.Sheets
   If LCase(wks.Name) <> "bestellung" And _
   LCase(wks.Name) <> "bestand" And _
   LCase(wks.Name) <> "ek" Then
       wks.Copy
       Pfad = "S:\_Vertraege_ET_WIL\Bestelldatei\"
       Datei = ActiveSheet.Name & " DS"
       
       If Not Dir(Pfad & Datei & ".CSV") = "" Then
          Zaehler = 1
          While Dir(Pfad & Datei & Zaehler) <> ""
             Zaehler = Zaehler + 1
          Wend
          Datei = Datei & Zaehler
       End If
       
       ActiveWorkbook.SaveAs Pfad & Datei, xlCSV, Local:=True
       ActiveWorkbook.Close False
   End If
Next wks
Application.ScreenUpdating = True
MsgBox "Dateien erfolgreich gespeichert"
End Sub

Im Falle, dass die Datei bereits vorhanden ist, wird sie statt unter "Tabelle1 DS" als "Tabelle1 DS1" gespeichert (bzw. DS2, DS3 usw.).

[deschroe]

Moin,

vielen lieben Dank.

Es funktioniert.