Option Explicit
Sub DoIt()
Dim strFolder As String
Dim rngA As Range, rngC As Range
On Error GoTo fail
strFolder = AskPath("Zielverzeichnis für Texte")
If Len(strFolder) = 0 Then GoTo fail
For Each rngA In SpalteWo.Areas
For Each rngC In rngA.Cells
MkTextFile strFolder & Trim(rngC.Value)
Next rngC
Next rngA
fail:
End Sub
Private Sub MkTextFile(ByVal strFilename As String)
Dim fs As FileSystemObject
Dim st As TextStream
On Error Resume Next
Set fs = CreateObject("Scripting.FileSystemObject")
Set st = fs.CreateTextFile(strFilename & ".txt", True)
st.WriteLine strFilename
On Error GoTo 0
Set st = Nothing
Set fs = Nothing
End Sub
Private Function AskPath(Optional Titel As String) As String
Dim objFileDialog As Office.FileDialog
Set objFileDialog = Application.FileDialog(MsoFileDialogType.msoFileDialogFolderPicker)
With objFileDialog
.ButtonName = "Auswahl übernehmen"
.Title = Titel
.InitialView = msoFileDialogViewList
.Show
If .SelectedItems.Count = 1 Then AskPath = (.SelectedItems(1)) & "\"
End With
End Function
Private Function SpalteWo() As Range
Dim myrow As Variant
On Error GoTo sfail
Set myrow = Application.InputBox(prompt:="Klick auf einen Text", Title:="Spaltenabfrage", Type:=8)
With Columns(myrow.Column)
Set SpalteWo = .ColumnDifferences(Comparison:=.Cells(.Cells.Count))
End With
On Error GoTo 0
sfail:
End Function