MSG Box Abfrage und evtl. neuen Namen vergeben

Computer: Software & Programmierung Office Software
#1

Hola an alle mal wieder, habe mir aus dem Internet folgendes Makro gebaut was auch super funktioniert.
Sub ProgrammNachWord()
Dim Dateiname As String
Dim Variable As String
Variable = Sheets(„Tabelle1“).Range(„Z1“)
Dateiname = „C:\Users“ & Variable & „.txt“
Set fs = CreateObject(„Scripting.FileSystemObject“)
Set Datei = fs.createtextfile(Dateiname, True)
Set quelle = Sheets(„Tabelle1“). Range(Cells(2, 26), Cells(Cells(65536, 1).End(xlUp).Row,26))
For Each zeile In quelle.Rows
For Each Zelle In zeile.Cells
Datei.write Zelle.Value Datei.write vbTab
Next
Datei.write vbNewLine
Next
Datei.Close
End Sub

Soweit so Gut. Aber wie bekomm ich da jetzt eine Abfrage rein das wenn der Programmname schon belegt ist?

z.B. Programm vorhanden, ueberschreiben, Ja, Nein. Wenn ja ok wenn Nein dann neuen Namen vergeben.

Danke schon mal für eure Hilfe. Ihr habt mich hier schon oft bei meinen Spielereien gerettet, auch dafür nochmal Danke.
Hasta luego
Carsten

#2

Hallo Carsten,

versuchs mal hiermit (ungetestet):

Option Explicit

Sub ProgrammNachWord()
 Dim Dateiname As String
 Dim Variable As String
 Dim fs, datei, quelle
 Dim zeile, zelle

 Variable = Sheets("Tabelle1").Range("Z1")
 Dateiname = "C:\Users\" & Variable & ".txt"
 If Dir(Dateiname) "" Then
 If MsgBox("Datei schon vorhanden" & Chr(10) & "Überschreiben?", vbYesNo Or vbDefaultButton2 Or vbQuestion, "S T O P !!") = vbNo Then Exit Sub
 End If
 Set fs = CreateObject("Scripting.FileSystemObject")
 Set datei = fs.createtextfile(Dateiname, True)
 Set quelle = Sheets("Tabelle1").Range(Cells(2, 26), Cells(Cells(65536, 1).End(xlUp).Row, 26))
 For Each zeile In quelle.Rows
 For Each zelle In zeile.Cells
 datei.write zelle.Value
 datei.write vbTab
 Next
 datei.write vbNewLine
 Next
 datei.Close
End Sub

Gruß, Andreas

#3

Hola Andreas, funktioniert einwandfrei. Danke dir. Ist es ein grosser Aufwand das noch um die Namensaenderung bei schon vorhandenem Namen zu ergaenzen? Werde mich mal weiterhin im Internet schlau machen. Nochmals vielen Dank
Carsten

#4

Wie wär’s hiermit?
Hallo Carsten,

hier mal eine andere Version:

Option Explicit

Sub ProgrammNachWord()
 Dim Dateiname As String
 Dim Variable As String
 Dim fs, datei, quelle
 Dim zeile, zelle

 Variable = Sheets("Tabelle1").Range("Z1")
 Dateiname = "C:\Users\" & Variable & ".txt"
 With Application.FileDialog(msoFileDialogSaveAs)
 .AllowMultiSelect = False
 .FilterIndex = 11
 .InitialFileName = Dateiname
 If .Show = 0 Then Exit Sub
 Dateiname = .SelectedItems(1)
 End With
' If Dir(Dateiname) "" Then
' If MsgBox("Datei schon vorhanden" & Chr(10) & "Überschreiben?", vbYesNo Or vbDefaultButton2 Or vbQuestion, "S T O P !!") = vbNo Then Exit Sub
' End If
 Set fs = CreateObject("Scripting.FileSystemObject")
 Set datei = fs.createtextfile(Dateiname, True)
 Set quelle = Sheets("Tabelle1").Range(Cells(2, 26), Cells(Cells(65536, 1).End(xlUp).Row, 26))
 For Each zeile In quelle.Rows
 For Each zelle In zeile.Cells
 datei.write zelle.Value
 datei.write vbTab
 Next
 datei.write vbNewLine
 Next
 datei.Close
End Sub

Wäre das so OK?

Gruß, Andreas

#5

Super Andreas. Leider gibt es bei mir immer einen Fehler wenn ich hier Sterne vergeben moechte. Weiss nicht was ich falsch mache. Von mir bekommst du auf jeden Fall einen. Fuer meine Spielerei ist das Makro so Perfekt. Danke dir fuer deine viele Arbeit.
Hasta luego
Carsten