Microsoft Excel

Herbers Excel/VBA-Archiv

Textdatei als Endlosschleife einlesen (5)


Betrifft: Textdatei als Endlosschleife einlesen (5) von: Rainer
Geschrieben am: 28.07.2017 10:45:24

Hallo Excelfreunde,

Nach einiger Abstinenz im Forum aufgrund beruflicher Veränderungen habe ich heute etwas Zeit, um eine Rückmeldung zu meinem alten Projekt "Textdatei als Endlosschleife einlesen" abzuliefern. Hier sind die alten Beiträge verlinkt:

https://www.herber.de/cgi-bin/callthread.pl?index=1523976
https://www.herber.de/cgi-bin/callthread.pl?index=1525132
https://www.herber.de/cgi-bin/callthread.pl?index=1528578
https://www.herber.de/cgi-bin/callthread.pl?index=1529873

Nach fleißiger Benutzung, Erweiterung und Optimierung bin ich mittlerweile sehr zufrieden mit dem Makro.

Die wichtigsten Erfahrungen:

Das notorische Bildschirmflackern (und auch der Performance-Verlust bei langen Laufzeiten) sind verschwunden, als ich alle Kopiervorgänge verändert habe von kopieren mit Excel-Funktionen (sinngemäß):

.Range("XY").Copy 
.Range("AB").PasteSpecial xlPasteValues
zu Kopieren mit Array als Zwischenspeicher:
Array = .Range("XY")
.Range("AB") = Array
Das hat sich sehr gelohnt. Immer während des Kopierens sind alle Diagramme und ActiveX Buttons verschwunden und wurden danach wieder eingeblendendet, sehr nervig.

Die zweite elementare Veränderung betrifft das Einlesen der Dateien, dies geschieht nun über "QueryTables" statt "Workbook.Open". Somit muss Excel nicht mehr in jedem Durchlauf 3 Dateien öffnen und schließen. Der ganze Code zum Einlesen hat sich auf ein kleines "Querry.Referesh" reduziert.

So sieht der Code nun aus:
Option Explicit

Public Datei(0 To 2) As String
Public SpeicherZeit(0 To 2) As Date
Public B7
Public XmaxScale
Public BolStop As Boolean
Public datStartTime As Date

Sub Makro1()
    Start
    Einlesen
End Sub

Sub Start()
'starten BEVOR das Messen beginnt
Dim WB As Workbook
Dim Import As Worksheet
Dim Sp()
Dim LC, LR, Statuscalc As Long
Dim i, TMP, TB, Spa As Integer
Dim Arr, SpecArr, j
Dim qt, BackgroundQuery
Set Import = ThisWorkbook.Sheets("IMPORT")
Sp = Array(2, 5, 8)

Import.Activate

KILLQUERY
Import.Range("A5:Z10000").Clear

Datei(0) = Import.Range("B2")
Datei(1) = Import.Range("B3")
Datei(2) = Import.Range("B4")

For i = 0 To 2
    SpeicherZeit(i) = FileDateTime(Datei(i))
    Import.Cells(7, Sp(i)) = FileDateTime(Datei(i))
    
    j = "TEXT;" & Datei(i)
    With Import.QueryTables.Add(Connection:=j, Destination:=Import.Cells(8, Sp(i)))
        .AdjustColumnWidth = False
        .FieldNames = True
        .FillAdjacentFormulas = False
        .Name = "MeasurementPosition" & (i)
        .PreserveFormatting = True
        .Refresh BackgroundQuery:=False
        .RefreshOnFileOpen = False
        .RefreshPeriod = 0
        .RefreshStyle = xlOverwriteCells
        .RowNumbers = False
        .SaveData = False
        .SavePassword = False
        .TextFileColumnDataTypes = Array(1, 1)
        .TextFileCommaDelimiter = True
        .TextFileConsecutiveDelimiter = False
        .TextFileParseType = xlDelimited
        .TextFilePlatform = 437
        .TextFilePromptOnRefresh = False
        .TextFileSemicolonDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileStartRow = 1
        .TextFileTabDelimiter = True
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileTrailingMinusNumbers = True
    End With
Next i
For Each qt In Import.QueryTables
On Error Resume Next
qt.Refresh (BackgroundQuery)
Next

BolStop = False

ThisWorkbook.Sheets("MAIN").Activate

End Sub

Sub Einlesen()
Dim WB As Workbook
Dim Import As Worksheet
Dim Sp()
Dim LC, LR, Statuscalc As Long
Dim i, TMP, TB, Spa As Integer
Dim Arr, SpecArr, j
Dim qt, BackgroundQuery

Set Import = ThisWorkbook.Sheets("Import")
Debug.Print "neu -Einlesen-" & Format(Now, "YYYY-MM-DD hh:mm:ss")
Sp = Array(2, 5, 8)

While BolStop = False

For Each qt In Import.QueryTables
qt.Refresh (BackgroundQuery)
Next

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    Statuscalc = .Calculation
    .Calculation = xlCalculationManual
    .AutoRecover.Enabled = False
End With

If BolStop = True Then GoTo Beenden

B7 = Import.Range("B7")     'Write the old Import time into B7

For i = 0 To 2
Import.Cells(7, Sp(i)) = FileDateTime(Datei(i))
Next i
'after import is finished, recalucate all

ThisWorkbook.Sheets("MAIN").Range("H9") = B7
Application.Calculate
     
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    DoEvents
    .ScreenUpdating = False
    .EnableEvents = False

End With
    
If Import.Range("B7") <> B7 Then 'Wert hat sich geändert
    B7 = Import.Range("B7")
    Set TB = ThisWorkbook.Sheets("EXPORT")
    Spa = 1 'Spalte A
    LR = TB.Cells(TB.Rows.Count, Spa).End(xlUp).Row + 1
    LR = IIf(LR < 4, 4, LR)
    LC = TB.Cells(1, TB.Columns.Count).End(xlToLeft).Column
    Arr = TB.Range(TB.Cells(3, 1), TB.Cells(3, LC))
    TB.Range(TB.Cells(LR, 1), TB.Cells(LR, LC)) = Arr
End If
    
If ThisWorkbook.Sheets("CHARTS").Cells(37, 2) <> XmaxScale Then 'Wert hat sich geändert
    Diagramm_Update
    XmaxScale = ThisWorkbook.Sheets("CHARTS").Cells(37, 2)
End If

Update_Warning

Update_RGB
    
Wend
    
Beenden:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = Statuscalc
        .AutoRecover.Enabled = True
    End With
End Sub

Sub Stopp_Click()
Dim TB As Worksheet
Set TB = ThisWorkbook.Sheets("MAIN")
    TB.Shapes("WARNING1").Visible = False
    TB.Shapes("WARNING2").Visible = False
    BolStop = True
    KILLQUERY
End Sub

Sub KILLQUERY()
Dim cn
    For Each cn In ThisWorkbook.Connections
        cn.Delete
    Next cn
    For Each cn In ActiveSheet.QueryTables
        cn.Delete
    Next cn
End Sub
Wie gesagt, ist eine feine Sache, nochmals vielen Dank an alle Helfer!

Das einzige was mich etwas stört ist, dass das Makro abbricht sobald man eine Zelle editieren will. Man kann also bei laufendem Makro keine Werte eintippen. Dies macht es aber erst seit ich die "Querytables" benutze. Die ältere Version mit "Workbook.Open" hatte dieses Problem nicht.

Gibt es dafür eine Erklärung?

Viele Grüße,

Rainer

  

Betrifft: AW: Textdatei als Endlosschleife einlesen (5) von: Rainer
Geschrieben am: 31.07.2017 11:49:11

Das einzige was mich etwas stört ist, dass das Makro abbricht sobald man eine Zelle editieren will. Man kann also bei laufendem Makro keine Werte eintippen. Dies macht es aber erst seit ich die "Querytables" benutze. Die ältere Version mit "Workbook.Open" hatte dieses Problem nicht.

Ich habe die Ursache gefunden. Es liegt nicht am "Workbook.Open", sondern an dem Ersetzen der Schleife. Die alte Version startet die Schleife neu mit

If Import.Cells(1, 1) = 0 Then
    BolStop = False
    datStartTime = Now + TimeValue("00:00:01")          'This is the interval of importing the  _
data
    Application.OnTime datStartTime, "Einlesen"
End If
und die neue Version benutzt eine Schleife:
While BolStop = False
...
Wend
In der alten Version wird der Sub durch manuelle Eingaben ebenso unterbrochen. Durch den "Application.OnTime" wird er aber neu gestartet und es fällt nicht auf, dass unterbrochen wurde.

Habe es gelöst durch folgenden Code:
Private Sub Worksheet_Change(ByVal Target As Range)
If BolStop = False Then Einlesen
End Sub

Solange also nicht durch eine Nutzereingabe unterbrochen wurde (BolStop = True), dann wird das Einlesen wieder neu gestartet.

Allerdings waren die "Workbook.Open" der Grund, warum es den Screensaver niemals aktiviert hat. Dies passiert nun leider. Aber da gibt es andere Wege...

Gruß,

Rainer


Beiträge aus den Excel-Beispielen zum Thema "Textdatei als Endlosschleife einlesen (5)"