Hallo Sabine,
sorry, ich habe deine Antwort etwas spät bemerkt, weil ich
gar nicht mehr damit gerechnet hatte ;-)
Die Erweiterung des Makros ist kein Problem, es wird nur
etwas länger. Der neu zu erstellende Ordner für die neuen
Excel wird als Unterordner in dem Ordner angelegt, in dem
die Datei mit den Makros gespeichert ist, der Ordnername
wird vom Benutzer in einer InputBox festgelegt. Wenn du das
gern anders hättest, sollte das auch kein Problem sein.
Weil ich nicht weiß, wie groß deine Dateien sind, wird ein
neues Blatt eingefügt, wenn alle 256 Spalten voll sind.
Den Sound, der nach dem Ende des Einlesens erklingt, kannst
du bei Bedarf selbst festlegen, indem du beim Aufruf der
sndPlaySound-Function statt tada.wav eine andere WAV-Datei
angibst. Hier nun der Code, der komplett in ein Modul gehört:
Declare Function sndPlaySound Lib "winmm" Alias "sndPlaySoundA" ( _
ByVal lpszSound As String, ByVal uFlags As Long) As Long
Sub TextdateienEinlesen()
Dim strFileName As String, intFileNummer As Integer, _
strInput As String, lngZeile As Long, intSpalte As Integer, _
wbkA As Workbook, wksA As Worksheet, vntNeuOrdner As Variant, _
lngTemp As Long, blnFehler As Boolean
Const strOrdner As String = "C:\Text\"
' Beispiel, Backslash am Ende beachten!
strFileName = Dir$(strOrdner & "*.txt")
If strFileName <> "" Then
' neuen Ordner erstellen
Do
blnFehler = False
vntNeuOrdner = Application.InputBox(Prompt:="Aktueller Ordner: " & _
ThisWorkbook.Path & "\" & vbCrLf & _
"Geben Sie den Namen des zu erstellenden Ordners an:", _
Title:="Neuen Ordner erstellen", Type:=2)
If vntNeuOrdner = False Then ' Abbrechen geklickt
Exit Sub
Else
On Error GoTo Fehler
MkDir ThisWorkbook.Path & "\" & CStr(vntNeuOrdner)
On Error GoTo 0
End If
Loop Until blnFehler = False
lngTemp = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Do
Set wbkA = Workbooks.Add
Set wksA = wbkA.ActiveSheet
intFileNummer = FreeFile
lngZeile = 1
intSpalte = 1
Open strOrdner & strFileName For Input As #intFileNummer
Do
Line Input #intFileNummer, strInput
wksA.Cells(lngZeile, intSpalte) = strInput
lngZeile = lngZeile + 1
If lngZeile = 101 Then
lngZeile = 1
intSpalte = intSpalte + 1
If intSpalte = 257 Then
' letzte Spalte voll - neues Blatt anlegen
Set wksA = wbkA.Worksheets.Add(After:=wksA)
lngZeile = 1
intSpalte = 1
End If
End If
Loop Until EOF(intFileNummer)
Close #intFileNummer
wbkA.Worksheets(1).Activate
wbkA.SaveAs ThisWorkbook.Path & "\" & CStr(vntNeuOrdner) & "\" & _
Split(strFileName, ".")(0) & ".xls"
wbkA.Close
strFileName = Dir$
Loop Until strFileName = ""
End If
Application.SheetsInNewWorkbook = lngTemp
sndPlaySound "C:\Windows\Media\tada.wav", 0
Exit Sub
Fehler:
blnFehler = True
MsgBox "Der Ordner konnte nicht erstellt werden." & vbCrLf & _
"Geben Sie einen anderen Namen an.", vbOKOnly + vbExclamation, _
"Neuen Ordner erstellen"
Resume Next
End Sub
Gruß Jürgen
|