Hallo Zentri,
- Ich weiß nicht in wie fern man diesen Vorgang
automatisieren kann. Ist es möglich den Ort der .txt Dateien
schon im Macro fest zu legen, damit ich den nicht immer
angeben muss?
Statt der Variablen varVerzeichnis das Ergebnis eines Auswahldialogs zuzuweisen, kann man ihr auch direkt den konstanten Wert zuweisen.
Genau so wäre es auch
praktisch wenn man das Speichern ebenfalls automatisieren
könnte um das Ganze zum beispiel als „Marketlogs.xlsx“ Datei
im gleichen Ordner ablegen könnte.
Auch das ist kein Problem mit der „SaveAs“-Methode kann man die erzeugte Datei auch direkt mit einem vorgegebenen Namen und Format speichern - ohne Dialoganzeige.
- Beim importieren der Dateien fragt er mich die ganze Zeit
ob ich die Informationen in der Zwischenablage speichern
möchte.
Das passiert in Excel wenn große Datenmengen kopiert werden und direkt danach die Datenquelle geschlossen wird.
Mit einer kleinen Dummy-Kopier-Anweisung für eine Zelle kann man das umgehen. Evtl. den Vorschlag von Reinhard verwenden und vor und nach der Anweisung zum Schließen der TXT-Datei die DisplayAlert-Anweisungen einfügen.
Gruß
Franz
Hier nochmals der komplette angepasste Code:
Sub TXT\_Dateien\_Importieren()
'Daten werden zunächst in ein Excelblatt importiert, dann eingelesen
Dim strArtikel As String, strOrt As String, strDatum As String, \_
strDateiTXT As String
Dim wbDaten As Workbook
Dim wksDaten As Worksheet
Dim wbImport As Workbook, strDatei As String
Dim wksImport As Worksheet
Dim ZeileImport As Long
Dim LetzteZeile As Long
Dim arrDateiname, strMldg As String
Dim varVerzeichnis
On Error GoTo Fehler
'Verzeichnis mit TXT-DAteien auswählen
varVerzeichnis = "C:\Documents and Settings\" \_
& "Administrator.JP\My Documents\EVE\logs\Marketlogs"
varVerzeichnis = "C:\Users\Public\" \_
& "Test\01"
' With Application.FileDialog(msoFileDialogFolderPicker)
' .AllowMultiSelect = False
' If .Show False Then
' varVerzeichnis = .SelectedItems(1)
' End If
' End With
'TXT-Dateien im Verzeichnis suchen
strDatei = Dir(varVerzeichnis & Application.PathSeparator & "\*.txt")
If strDatei "" Then
'Ausgabedatei erstellen
Set wbImport = Workbooks.Add(Template:=xlWBATWorksheet)
Set wksImport = wbImport.Worksheets(1)
With wksImport
'Spaltentitel
ZeileImport = 1
.Cells(ZeileImport, 1) = "Ort"
.Cells(ZeileImport, 2) = "Artikel"
.Cells(ZeileImport, 3) = "Datum"
.Cells(ZeileImport, 4) = "File"
.Cells(ZeileImport, 5) = "Preis"
.Cells(ZeileImport, 6) = "Menge"
.Cells(ZeileImport, 7) = "Dauer"
.Cells(ZeileImport, 8) = "Anbieter"
'Spalten formatieren
.Columns(1).NumberFormat = "@"
.Columns(2).NumberFormat = "@"
.Columns(3).NumberFormat = "DD.MM.YYYY"
.Columns(4).NumberFormat = "@"
.Columns(5).NumberFormat = "#,##0.00"
.Columns(6).NumberFormat = "general"
.Columns(7).NumberFormat = "general"
.Columns(8).NumberFormat = "@"
'1. Zeile fixieren
Range("A2").Select
ActiveWindow.FreezePanes = True
End With
ZeileImport = ZeileImport + 1
Application.ScreenUpdating = False
'Daten aus Textdateien importieren
Do Until strDatei = ""
Workbooks.OpenText Filename:= \_
varVerzeichnis & Application.PathSeparator & strDatei, \_
Origin:=xlWindows, StartRow:=2, DataType:=xlDelimited, \_
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, \_
Tab:=False, Semicolon:=False, Comma:=True, Space:=False, Other:=False, \_
FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 2)), \_
DecimalSeparator:=".", ThousandsSeparator:=" ", TrailingMinusNumbers:=True
'Infos aus Dateinamen holen
arrDateiname = Split(strDatei, "-")
strArtikel = arrDateiname(0)
strOrt = arrDateiname(1)
strDatum = Replace(Left(arrDateiname(2), 10), ".", "-")
strDateiTXT = Mid(arrDateiname(2), 12)
Set wbDaten = ActiveWorkbook
Set wksDaten = wbDaten.Worksheets(1)
With wksDaten
LetzteZeile = .Cells(.Rows.Count, 1).End(xlUp).Row
'4 Leerspalten einfügen
.Range(.Columns(1), .Columns(4)).Insert
'Infos aus Dateiname eintragen
.Range(.Cells(1, 1), .Cells(LetzteZeile, 1)).Value = strOrt
.Range(.Cells(1, 2), .Cells(LetzteZeile, 2)).Value = strArtikel
.Range(.Cells(1, 3), .Cells(LetzteZeile, 3)).Value = CDate(strDatum)
.Range(.Cells(1, 4), .Cells(LetzteZeile, 4)).Value = strDateiTXT
'Daten kopieren
.Range(.Cells(1, 1), .Cells(LetzteZeile, 8)).Copy
End With
'Daten in Zieldatei einfügen
wksImport.Cells(ZeileImport, 1).PasteSpecial Paste:=xlPasteValues
ZeileImport = ZeileImport + LetzteZeile
'Dummy-Koperen, um Meldung für größe Datenmenge zu unterdrücken
ActiveCell.Copy
Application.CutCopyMode = False
'TXT-Datei wieder schliessen
wbDaten.Close savechanges:=False
Set wbDaten = Nothing
Set wksDaten = Nothing
strDatei = Dir
Loop
'Spaltenbreite optimieren
wksImport.Columns.AutoFit
Application.ScreenUpdating = True
Else
MsgBox "keine TXT-DAteien im Verzeichnis " & varVerzeichnis
End If
' 'Dateispeichern unter Dialog anzeigen
' Application.Dialogs(xlDialogSaveAs).Show Arg1:=strDatei
' Datei wird im vorgegeben Verzeichnis unter dem Namen gespeichert.
If Val(Left(Application.Version, 2)) \>= 12 Then
'im Excel 2007er-Format ohne Makros - xlsx
'FileFormat = xlOpenXMLWorkbook
wbImport.SaveAs Filename:=varVerzeichnis & Application.PathSeparator \_
& "Marketlogs", FileFormat:=51, addtomru:=True
'im Excel 2007er-binär Format - xlsb
'FileFormat = xlExcel12
' wbImport.SaveAs Filename:=varVerzeichnis & Application.PathSeparator \_
& "Marketlogs", FileFormat:=xlExcel12, addtomru:=True
Else
'im Excel 97-2003-Format - xls - bei Anwendung mit älteren Excelversionen
'FileFormat = xlWorkbookNormal
wbImport.SaveAs Filename:=varVerzeichnis & Application.PathSeparator \_
& "Marketlogs", FileFormat:=-4143, addtomru:=True
End If
Err.Clear
Fehler:
Application.ScreenUpdating = True
With Err
If .Number 0 Then
Select Case .Number
Case 1004
'Speichern unter anderem Namen wurde mit nein oder Abbrechen abgebrochen
Case Else
strMldg = "Fehler # " & Str(Err.Number) & " wurde ausgelöst von " \_
& Err.Source & Chr(13) & Err.Description
MsgBox strMldg, , "Fehler", Err.HelpFile, Err.HelpContext
If Not wbDaten Is Nothing Then wbDaten.Close savechanges:=False
Set wksDaten = Nothing
Set wbDaten = Nothing
End Select
End If
End With
Set wbImport = Nothing
Set wksImport = Nothing
End Sub
