Makro löscht Dateien
30.09.2005 14:04:00
ReSt
Ich habe ein grösseres Problem mit unten angeführtem Makro.
Ich habe Windows XP SP2 Excel 2003.
Mit dem Makro hole ich eine .txt-Datei welche umgewandelt wird. Dies geschieht über Excel und ist am Schluss wieder eine .txt-Datei.
Mein Problem ist, wenn ich die Datei auf einem Laufwerk ausser C:\ importiere,löscht es mir alle Dateien im Ordner wo ich die .txt-Datei auslese.
Wenn ich das Ganze auf der lokalen Festplatte ausführe, geht nichts verloren.
Im Makro hole ich ja nur Daten und speichere nichts zurück.(so meine ich jedenfalls).
Wer weiss Rat
Gruss Reto
Option Explicit
Sub Konvertierung()
Dim wkb As Workbook '################################################
Dim Konsttemp As String '### ###
Dim Fixdatei As String '### ###
Dim tempdatei As String '### ###
Dim fileToOpen As String '### ###
Dim Plattenkoordinaten As String '################################################
Dim lzeile As String
'########################################################################################
' D E F I N I T I O N E N D E R P F A D E
Plattenkoordinaten = "" & Worksheets("NC-Datei").Range("J8") & "" 'Plattenkoordinaten.xls
Konsttemp = "" & Worksheets("NC-Datei").Range("J14") & "" 'temp -k Datei.txt
Fixdatei = "" & Worksheets("NC-Datei").Range("J16") & "" 'eff. K-Datei
tempdatei = "" & Worksheets("NC-Datei").Range("J10") & "" '
'########################################################################################
Application.ScreenUpdating = False 'Unterdrückung der fortlaufenden visuellen Aktualität
'----------------------------------------------------------------------------------------
Workbooks.Open Filename:=Plattenkoordinaten 'öffnet die Plattenkooordinaten-Datei
'----------------------------------------------------------------------------------------
Application.DisplayAlerts = False 'Meldung unterdrücken
'temporär als .txt Datei abspeichern, somit ist die Plattenkoordinaten-Datei weg !!
ActiveWorkbook.SaveAs Filename:=Konsttemp & ".txt", _
FileFormat:=xlText, CreateBackup:=False
Application.DisplayAlerts = True
'----------------------------------------------------------------------------------------
'zur Vereinfachung des Datentransfers, wird eine Kopie der jetzigen temporären
'(...-k.xls Datei) der Plattenkoordinatenvorlagedaten in "Tabelle1" erstellt
Cells.Select ' Zellen markieren
Selection.Copy ' Zellen kopieren
Sheets.Add ' Tabelle1 einfügen
Cells.Select ' Zellen markieren
ActiveSheet.Paste ' Inhalt einfügen
'Es wird noch ein 2.Tabellenblatt erstellt und liegt für die Einfügung der Koordinaten
'von der Konstruktionsdatei parat. Nachher werden die Inhalte eingefügt.
Sheets.Add '("Tabelle2 einfügen")
'''''''''''''''Application.ScreenUpdating = True 'Unterdrückung der fortlaufenden visuellen Aktualität
'########################################################################################
Selection:
fileToOpen = Application _
.GetOpenFilename("Text Files (*.txt), *.txt", 1, _
"Suche und wähle deine zu importierende .txt-Datei aus... (Konstruktions-.txt-Datei)", MultiSelect:=False)
If fileToOpen = "Falsch" Then
MsgBox "Die Datei konnte wegen Benutzerabbruch nicht gespeichert werden!", vbOKOnly + vbCritical, "Speichern fehlgeschlagen"
Application.DisplayAlerts = False 'Unterbindung der Nachfrage, dass nicht speichern
ActiveWorkbook.Close savechanges:=False ' alle Änderungen werden verworfen
Range("A2").Select
Else
'Konvertierung
Workbooks.OpenText Filename:=fileToOpen, Origin:=xlWindows, _
StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False _
, Space:=False, Other:=True, OtherChar:="|", FieldInfo:=Array(Array(1, 1 _
), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1))
'Zeile 1-3 und die letzte Zeile löschen
Dim LoLetzte As Long
LoLetzte = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
Rows(LoLetzte).Delete
Rows("1:3").Delete
'alle Zellen markieren und kopieren
Columns("B:E").Select
Selection.Cut
'##########################################################################################
'Die Daten werden nun in die Tabelle 2 der effektiven Datei eingefügt
'Sinn und Zweck = Vereinfachung des Transfers
Workbooks(2).Worksheets("Tabelle2").Activate
Columns("B:E").Select
ActiveSheet.Paste
'##########################################################################################
'Die Datentransferübung beginnt hier
Columns(2).Cut Sheets("Tabelle1").Columns(11)
'--------------------------------------------
Worksheets("Tabelle2").Activate
Columns(3).Cut Sheets("Tabelle1").Columns(4)
'--------------------------------------------
Worksheets("Tabelle2").Activate
Columns(4).Cut Sheets("Tabelle1").Columns(6)
'--------------------------------------------
Worksheets("Tabelle2").Activate
Columns(5).Cut Sheets("Tabelle1").Columns(12)
Range("B1").Select
'##########################################################################################
'löschen der unnötigen Blätter ausser Tabelle 1
Dim InIn As Integer
Application.DisplayAlerts = False
For InIn = Worksheets.Count To 1 Step -1
If Worksheets(InIn).Name <> "Tabelle1" Then Worksheets(InIn).Delete
Next InIn
Application.DisplayAlerts = True
'leere Zeilen löschen beginnend ab Spalte D >> siehe unten : Rows(Cells(Rows.Count, 4)
Rows(Cells(Rows.Count, 4).End(xlUp).Row + 1 & ":" & _
ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1).Delete
'-----------------------------------------------------------
'-----------------------------------------------------------
'Hier werden alle Kommazahlen in Zahlen mit Punkten geändert
Range("A1:L3100").Select
'Columns("A:L").Select
Call KommaPunkt
'-----------------------------------------------------------
Call Kopfzeile
lzeile = Cells(Rows.Count, 1).End(xlUp).Row
Cells(lzeile, 1).Activate
Call Fusszeile
'-----------------------------------------------------------
'##########################################################################################
'abspeichern als -k-Datei definitiv Unterbindung der Nachfrage,ob überschrieben werden soll
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=Fixdatei & ".txt", _
FileFormat:=xlText, CreateBackup:=False
ActiveWorkbook.Close savechanges:=False ' alle Änderungen werden verworfen
ActiveWorkbook.Close savechanges:=False ' alle Änderungen werden verworfen
'##########################################################################################
Range("A50").Value = tempdatei
On Error GoTo ende:
ChDir tempdatei
Kill "*.*"
ende:
'------------------------------------------------------------------------------------------
Application.ScreenUpdating = True 'Unterdrückung der fortlaufenden visuellen Aktualität
'------------------------------------------------------------------------------------------
MsgBox "Die Datei ist jetzt erstellt, du bist ein Glückspilz !!!" & Chr(13) & Chr(13) & _
"Konvertiere doch gleich die anderen .txt Dateien (das ist effizienter)" _
, vbInformation, "Information"
End If
Range("A2").Select
End Sub