3
Suche VBA Hilfestellung für Autoimport mehre TXT zum auswerten
Schönen guten Tag Community,
Es sind mehre text die immer den selben Inhalt haben:
1,1,37,37,469,495,0,495,0,508,0,38,1,508,0,482,0,37
Die Anzahl ist immer die selbe es kann aber auch Text sein der darin steht.
Eine TxT kan mehre untereinander geschriebene Zeilen haben.
Quasi von Oben nur anderen Zahlen.
Mit einzelnen TXT Files mit nur 1ner Zeile Inhalt funktioniert das, aber so nicht weshalb auch immer.
Wenn noch jemand einen string hätte damit ich das Verzeichnis weglassen kann und das ganze immer im Verzeichnis ausgeführt wird indem das Sheet liegt, wäre Prima.
Viele grüße euer Vidan
Sub Input_Files_From_Path()
Dim strPfad As String
Dim strDatei As String
Dim intFF As Integer
Dim strText As String
Dim wks As Worksheet
Set wks = Tabelle1
strPfad = "M:\test\test1" 'hier liegen die files (serververzeichnis)
strDatei = Dir(strPfad & "*.txt") 'auswahl das es txt sind
Do While strDatei <> ""
intFF = FreeFile()
Open strPfad & strDatei For Input As #intFF
strText = Input(LOF(1), #intFF)
Close #intFF
WriteToClp strText
With wks
With .Cells(Rows.Count, 1).End(xlUp).Offset(1)
.Value = 1
.TextToColumns .Cells(1), Comma:=True 'komma als trennung
wks.Paste .Cells(1)
End With
End With
strDatei = Dir()
Loop
End Sub
Public Sub WriteToClp(txt As String)
Dim IE As Object
Set IE = CreateObject("HTMLfile")
IE.ParentWindow.ClipboardData.SetData "text", txt & ""
Set IE = Nothing
End SubEs sind mehre text die immer den selben Inhalt haben:
1,1,37,37,469,495,0,495,0,508,0,38,1,508,0,482,0,37
Die Anzahl ist immer die selbe es kann aber auch Text sein der darin steht.
Eine TxT kan mehre untereinander geschriebene Zeilen haben.
Quasi von Oben nur anderen Zahlen.
Mit einzelnen TXT Files mit nur 1ner Zeile Inhalt funktioniert das, aber so nicht weshalb auch immer.
Wenn noch jemand einen string hätte damit ich das Verzeichnis weglassen kann und das ganze immer im Verzeichnis ausgeführt wird indem das Sheet liegt, wäre Prima.
Viele grüße euer Vidan
Auf Facebook teilen
Auf Twitter teilen
Auf Reddit teilen
Auf Linkedin teilenBitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben
Content-ID: 234201
Url: https://administrator.de/forum/suche-vba-hilfestellung-fuer-autoimport-mehre-txt-zum-auswerten-234201.html
Ausgedruckt am: 23.12.2024 um 02:12 Uhr
3 Kommentare
Neuester Kommentar
Hallo Vidan011!
Versuchs mal damit:
Wobei sich die Text-Dateien im gleichen Ordner befinden müssen, wie die Arbeitsmappe.
Grüße
Der Ratsuchende
Versuchs mal damit:
Option Explicit
Private Const sSheetName = "Tabelle1"
Sub Input_Files_From_Path()
Dim oFso As Object, oFile As Object
Set oFso = CreateObject("Scripting.FileSystemObject")
Application.ScreenUpdating = False
For Each oFile In oFso.GetFolder(ThisWorkbook.Path).Files
If LCase(oFso.GetExtensionName(oFile.Name)) = "txt" Then
Call TextImport(oFile.Path)
End If
Next
Application.ScreenUpdating = True
End Sub
Private Sub TextImport(ByRef sFileName)
Dim iRowNext As Long
With Sheets(sSheetName)
iRowNext = .Cells(.Rows.Count, "A").End(xlUp).Row
If Not IsEmpty(.Range("A1")) Then
iRowNext = iRowNext + 1
End If
With .QueryTables.Add(Connection:="TEXT;" & sFileName, Destination:=.Cells(iRowNext, "A"))
.AdjustColumnWidth = True 'Spaltenbreite automatisch anpassen True/False
.TextFilePlatform = 1252
.TextFileTextQualifier = xlTextQualifierNone
.TextFileParseType = xlDelimited
.TextFileCommaDelimiter = True
.Refresh BackgroundQuery:=False
.Delete
End With
End With
End SubGrüße
Der Ratsuchende
Guten Tag,
sieht TOP aus :D Funktionieren tut das ganze genau so wie Gewünscht!
Aber ich hatte schon Probleme mit meinem VBA Model, bei dir steig ich garnichtmehr durch :D
*wieder ab ans lernbuch*
Grüße Vidan
sieht TOP aus :D Funktionieren tut das ganze genau so wie Gewünscht!
Aber ich hatte schon Probleme mit meinem VBA Model, bei dir steig ich garnichtmehr durch :D
*wieder ab ans lernbuch*
Grüße Vidan
Hallo Vidan!
Freut mich, wenn es wie gewünscht funktioniert
Also, diese Klasse unterstützt die neueren und umfangreicheren Dateisystem-Funktionen.
Diese Klasse kannst Du auch über den Object-Katalog>Klassen>Rechtsklick>Verweise einbinden. Die Klasse trägt den Namen 'Microsoft Scripting Runtime'. Um alle verfügbaren Funktionen zu erfahren, wählst Du im Object-Katalog im obersten Auswahlfeld anstatt <Alle Biblitheken> einfach <Scripting> aus.
Die Deklaration würde nach Einbindung der Klasse dann so lauten:
Die Funktion QueryTable entspricht der Funktion 'Externe Daten abrufen' in der Excel-Oberfläche>Daten. QueryTable bietet eine ganze Reihe von Möglichkeiten(Text-Import, Webabfragen...). Von daher macht es durchaus Sinn, mal ein Makro mit den gewünschten Optionen (Abfrage speichern) aufzuzeichnen und sich anschließend den Code anzusehen. Als letzte Anweisung sollte immer das '.Delete' folgen, weile ansonsten jede einzelne Abfrage gespeichert und dadurch Zellbereiche mit einer Abfrage belegt werden (rotes Ausrufezeichen zum aktualisieren), was nicht erwünscht ist, weil es ja keine konstanten Abfragen, also immer gleiche Text-Dateien mit gleicher Zeilenanzahl sind...
Grüße
Der Ratsuchende
Freut mich, wenn es wie gewünscht funktioniert
Also, diese Klasse unterstützt die neueren und umfangreicheren Dateisystem-Funktionen.
Dim oFso As Object
Set oFso = CreateObject("Scripting.FileSystemObject") Die Deklaration würde nach Einbindung der Klasse dann so lauten:
Dim oFso As FileSystemObject
Set oFso = New FileSystemObjectDie Funktion QueryTable entspricht der Funktion 'Externe Daten abrufen' in der Excel-Oberfläche>Daten. QueryTable bietet eine ganze Reihe von Möglichkeiten(Text-Import, Webabfragen...). Von daher macht es durchaus Sinn, mal ein Makro mit den gewünschten Optionen (Abfrage speichern) aufzuzeichnen und sich anschließend den Code anzusehen. Als letzte Anweisung sollte immer das '.Delete' folgen, weile ansonsten jede einzelne Abfrage gespeichert und dadurch Zellbereiche mit einer Abfrage belegt werden (rotes Ausrufezeichen zum aktualisieren), was nicht erwünscht ist, weil es ja keine konstanten Abfragen, also immer gleiche Text-Dateien mit gleicher Zeilenanzahl sind...
Grüße
Der Ratsuchende
