Neues Makro
31.12.2002 17:47:29
Ramses
Hallo,Ist ungetestet,.. sollte aber funktionieren:-)
Option Explicit
Sub Save_Datarows_at_txt_Files()
'Daten stehen in einer Zeile und jede Zeile soll als Textdatei in einem
'frei wählbaren Verzeichnis gespeichert werden
'Der Dateiname steht in Spalte 6
Dim Pfad As String, NewDrive As String, Temp As Variant
Dim i As Long, Cr As Long, Cc As Integer, DInt As Integer
Dim Suchdialog As FileDialog
Dim wkb As String, wks1 As String, txtName As String
Set Suchdialog = Application.FileDialog(msoFileDialogFolderPicker)
'Variablen füllen
Cr = 65536
Cc = 1
wkb = ActiveWorkbook.Name
wks1 = ActiveSheet.Name
'Öffnet einen Dialog indem der Pfad elegant wie im normalen
'Datei-Dialog gewählt werden kann.
With Suchdialog
.Title = "Bitte wählen Sie ein Verzeichnis aus"
'Environ(25) ermittelt den Aktuellen Userpfad
.InitialFileName = Environ(25) & "\Eigene Dateien\"
.ButtonName = "Auswahl übernehmen"
.Show
If .SelectedItems.Count = 0 Then
MsgBox "Sie haben kein Verzeichnis ausgewählt", vbInformation
Set Suchdialog = Nothing
Exit Sub
Else
For DInt = 1 To 1
Pfad = Pfad & .SelectedItems(DInt)
Next DInt
End If
'Weil der komplette Pfad der Variable übergeben wurde
'kann das Laufwerk extrahiert werden
NewDrive = Left(Pfad, 3)
End With
'letzte Zelle der Datensätze suchen
If Cells(Cr, Cc) = "" Then
Cr = Cells(Cr, Cc).End(xlUp).Row
End If
On Error GoTo txtError
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For i = 1 To Cr
txtName = Worksheets(wks1).Cells(i, Cc + 5) & ".txt"
Workbooks.Add
ActiveWorkbook.SaveAs Filename:=Pfad & "\" & txtName, FileFormat:=xlText, CreateBackup:=False
Temp = i & "= " & Workbooks(wkb).Worksheets(wks1).Cells(i, Cc)
Workbooks(txtName).Worksheets(1).Cells(i, Cc) = Temp
Temp = i + 1 & "= " & Workbooks(wkb).Worksheets(wks1).Cells(i, Cc + 1)
Workbooks(txtName).Worksheets(1).Cells(i + 1, Cc) = Temp
Temp = i + 2 & "= " & Workbooks(wkb).Worksheets(wks1).Cells(i, Cc + 2)
Workbooks(txtName).Worksheets(1).Cells(i + 2, Cc) = Temp
Temp = i + 3 & "= " & Workbooks(wkb).Worksheets(wks1).Cells(i, Cc + 3)
Workbooks(txtName).Worksheets(1).Cells(i + 3, Cc) = Temp
Temp = i + 4 & "= " & Format(Workbooks(wkb).Worksheets(wks1).Cells(i, Cc + 4))
Workbooks(txtName).Worksheets(1).Cells(i + 4, Cc) = Temp
Workbooks(txtName).Save
Workbooks(txtName).Close
Next i
Checkout:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Exit SubtxtError:
MsgBox Err.Number & ": " & Err.Description
Resume Checkout
End Sub
Code eingefügt mit Syntaxhighlighter 1.16
Gruss Rainer