Trennzeichen bei .dat files
01.12.2014 10:07:44
Annabelle
ich habe ein Makro, dass .dat Files einliest. Dieses funktioniert auch wunderbar, jedoch möchte ich nun auch noch andere dat Files einlesen. Die Daten darin sind jedoch mit einem Leerzeichen jeweils abgetrennt. Ich habe leider keine Idee wie ich das in meinem bisherigen Makro ändere. Ich hatte an sich gedacht, dass ich es hier ändere: .TextFileTabDelimiter = True also einfach Tab durch Space ersetze, das funktioniert jedoch nicht.
Ich wäre froh über Hilfe
Danke schonmal
Gruß
Annabelle
Anbei mein bisheriger Quellcode:
Sub hist_Datenimport()
MsgBox "Alle Daten werden gelöscht"
Cells.Select
Selection.Clear
Dim intRow As Long
Dim Zahl As Long
Dim letztespalte As Long
Dim strVerzeichnis As String
Dim Pixel As Long
Dim strDateiname As String
Dim strFeld As String
Dim letzteZeile As Long
Dim lngSpalte As Long
Dim blnWithHeader As Boolean
Dim Zelle As Range
Dim AppShell As Object
Dim BrowseDir As Variant
Set AppShell = CreateObject("Shell.Application")
Set BrowseDir = AppShell.BrowseForFolder(0, "Ordner auswählen", &H1000, 17)
On Error Resume Next
strVerzeichnis = BrowseDir.items().Item().Path
If strVerzeichnis = "" Then Exit Sub
On Error GoTo 0
lngSpalte = 2
Zahl = 1
Pixel = 1
blnWithHeader = True
If Right$(strVerzeichnis, 1) "\" Then strVerzeichnis = strVerzeichnis & "\"
strDateiname = Dir(strVerzeichnis & "*.dat")
Application.ScreenUpdating = False
Do While strDateiname vbNullString
strFeld = Left$(strDateiname, Len(strDateiname) - 4)
Call Import(Cells(1, lngSpalte), strVerzeichnis & strDateiname, strFeld, blnWithHeader)
lngSpalte = lngSpalte + 1
If blnWithHeader Then blnWithHeader = False
strDateiname = Dir()
Loop
Application.ScreenUpdating = True
End Sub
Sub Import(rngZielZelle As Range, strDatienamenPfad As String, strFeld As String, Optional blnWithHeader As Boolean)
Dim rngZiel As Range
Dim rngFeld As Range
Dim avarTextFileColumnDataTypes As Variant
Dim laengen(100) As Long
Dim werte(100, 1000)
If blnWithHeader Then
Set rngFeld = rngZielZelle
Set rngZiel = rngZielZelle.Offset(1, -1)
avarTextFileColumnDataTypes = Array(1, 1, 1)
Else
Set rngFeld = rngZielZelle
Set rngZiel = rngZielZelle.Offset(1)
avarTextFileColumnDataTypes = Array(9, 1, 1)
End If
rngFeld.Value = strFeld
Call TextTesten(strDatienamenPfad)
With rngZielZelle.Worksheet.QueryTables.Add(Connection:="TEXT;" & strDatienamenPfad, Destination:=rngZiel)
.RefreshStyle = xlOverwriteCells
.SaveData = False
.AdjustColumnWidth = False
.TextFilePlatform = 850
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileTabDelimiter = True
.TextFileColumnDataTypes = avarTextFileColumnDataTypes
.Refresh BackgroundQuery:=False
.Delete
letztespalte = Cells(30, Columns.Count).End(xlToLeft).Column
For intRow = 2 To letztespalte
letzteZeile = ActiveSheet.Cells(1048576, intRow).End(xlUp).Row
laengen(intRow - 1) = letzteZeile
For Zeile = 2 To letzteZeile
werte(intRow - 1, Zeile - 1) = Cells(Zeile, intRow)
Next
If letzteZeile > Pixel Then
Pixel = letzteZeile
End If
Next
For Zahl = 2 To Pixel
Cells(Zahl, 1).Value = Zahl - 1
Next Zahl
End With
' Text-Zahl in Zahl umwandeln + formatieren
With rngFeld.Offset(1).Resize(rngFeld.Worksheet.Rows.Count - rngFeld.Row)
.Replace ".", ".", xlPart
.NumberFormat = "#,##0.0000"
End With
Set rngFeld = Nothing
Set rngZiel = Nothing
End Sub
Public Sub TextTesten(sPfad As String)
'Dim sPfad As String,
Dim sText As String
sText = dat_ReadText(sPfad)
'Wenn "." im Text dann ists US Format und umwandeln
If InStr(sText, ".") Then
sText = Replace(sText, ",", "")
sText = Replace(sText, ".", ",")
dat_WriteText sPfad, sText
End If
End Sub
Public Function dat_ReadText(DerPfad As String) As String
Dim sText As String, iFrei As Integer, i As Long
On Error GoTo Fehler
sText = ""
iFrei = FreeFile
Open DerPfad For Binary Access Read As #iFrei
i = LOF(iFrei)
sText = String(i, 0)
Get #iFrei, , sText
Close #iFrei
dat_ReadText = sText
Exit Function
Fehler:
MsgBox Err.Description
End Function
Public Sub dat_WriteText(DerPfad As String, DerText As String)
Dim iFrei As Integer
On Error GoTo Fehler
iFrei = FreeFile
Open DerPfad For Output As #iFrei
Print #iFrei, DerText;
Close #iFrei
Exit Sub
Fehler:
MsgBox Err.Description
End Sub