Maximale Anzahl an Datenpunkten in einer Datenreih

Function Round(wert As Double, Delimeter As Integer) As Double
Dim i%, Faktor As Integer
Dim iwert As Long
Faktor = 1
For i = 1 To Delimeter
Faktor = Faktor * 10
Next i
wert = wert * Faktor
iwert = Int(wert)
If wert - iwert >= 0.5 Then
iwert = iwert + 1
End If
Round = iwert / Faktor
End Function

Function Split(Strings As String, Breakchar As String)
Dim i%, count As Integer
Dim Feld As String
Dim Felder() As String
count = 0
If Len(Strings) > 3 Then
For i = 1 To Len(Strings)
If (Mid(Strings, i, Len(Breakchar)) = Breakchar) Or (i = Len(Strings)) Then
If i = Len(Strings) Then
Feld = Feld + Mid(Strings, i, 1)
End If
ReDim Preserve Felder(count)
Felder(count) = Trim(Feld)
Feld = ""
count = count + 1
Else
Feld = Feld + Mid(Strings, i, 1)
End If
Next i
Else
ReDim Preserve Felder(count)
Felder(count) = Strings
End If
Split = Felder
End Function

Function Replace(Zeichenkette As String, altzeichen As String, neuzeichen As String _
, count As Integer, Optional length As Integer, Optional compare As Integer)
Dim neuezeichenkette As String
Dim anfang As Integer
If (length = nil) Or (length > Len(Zeichenkette)) Then
length = Len(Zeichenkette)
End If
If (count = length) Then
count = 1
End If
anfang = InStr(count, Mid(Zeichenkette, count, length), altzeichen, compare)
If anfang > 0 Then
If count > 1 Then
neuezeichenkette = Mid(Zeichenkette, 1, count - 1) + Mid(Zeichenkette, count, anfang - 1) +  _
_
neuzeichen + Right(Zeichenkette, length - Len(altzeichen) - anfang + 1)
Else
neuezeichenkette = Left(Zeichenkette, anfang - 1) + neuzeichen + _
Right(Zeichenkette, Len(Zeichenkette) - Len(altzeichen) - anfang + 1)
End If
Else
neuezeichenkette = Zeichenkette
End If
Replace = neuezeichenkette
End Function

Sub einlesen()
' einlesen Makro
' Dateien einlesen
' Tastenkombination: Strg+e
Application.ScreenUpdating = False
SheetName = ActiveSheet.Name
If (SheetName = "1. Messfahrt") Or (SheetName = "2. Messfahrt") Then
Dim Baulos As Boolean
Dim datei$, d1$, s As String
Dim i%, ii%, d2%, d3%, d4%, d5%, d6%, d31%, r%, r1%, ra%, c%, z%, km2anzahl As Integer
Dim Abschnittr#, km2von#, km2bis#, km2mw As Double
Baulos = False
If min_ = 0 Then
min_ = 10000000
min_1 = -100000
End If
zeilensprung = 15
d2 = 3
d3 = 4
d31 = 1
r = 24
c = 2
z = 1
datei = ""
fileToOpen = Application _
.GetOpenFilename("Text Files (*.txt), *.txt")
If fileToOpen  False Then
If (SheetName = "2. Messfahrt") Then
sca = Sheets.count
For sc = 1 To sca
If sc  " " Then
' aus *.roh-Datei Bauweise und OD/FS holen
d1 = datei
d1 = Mid(d1, 1, Len(d1) - 3) + "roh"
On Error GoTo ErrorHandler:
Set FS = CreateObject("Scripting.FileSystemObject")
Set f = FS.OpenTextFile(d1)
Do While d1  "[L]"
d1 = f.ReadLine
Loop
d1 = f.ReadLine
i = 0
Do While i  True
datei = f.ReadLine
If i = 1 And datei > " " Then
d1 = Trim(Mid(datei, 49, 10))
' Erfassungsdatum
ActiveSheet.Cells(18, 4).Value = d1
d1 = Trim(Mid(datei, 59, 10))
' Erfassungszeit
ActiveSheet.Cells(19, 4).Value = d1
ActiveSheet.Cells(21, 4).Value = ""
ElseIf i = 2 And datei > " " Then
d1 = Trim(datei)
' Bemerkungen
ActiveSheet.Cells(21, 4).Value = d1
ElseIf i = 3 And datei > " " Then
d1 = Trim(Mid(datei, 16, 20))
' Land
ActiveSheet.Cells(7, 4).Value = d1
d1 = Trim(Mid(datei, 53, 20))
' Bemerkung Messart
ActiveSheet.Cells(21, 4).Value = ActiveSheet.Cells(21, 4).Value + " " + d1
ElseIf i = 4 And datei > " " Then
d1 = Trim(Mid(datei, 16, 20))
' Strasse
ActiveSheet.Cells(9, 4).Value = d1
d1 = Trim(Mid(datei, 53, 20))
' V-soll
vsoll = Trim(Mid(d1, 1, InStr(1, d1, " ", 1) - 1))
ActiveSheet.Cells(16, 4).Value = vsoll
ElseIf i = 5 And datei > " " Then
d1 = Trim(Mid(datei, 16, 20))
' Messrichtung
'          ActiveSheet.Cells(11, 4).Value = d1
d1 = Trim(Mid(datei, 53, 20))
' Reifennummer
ActiveSheet.Cells(7, 13).Value = d1
ElseIf i = 6 And datei > " " Then
d1 = Trim(Mid(datei, 16, 20))
' Bauamt
ActiveSheet.Cells(8, 4).Value = d1
d1 = Trim(Mid(datei, 53, 20))
If InStr(1, d1, ".", vbTextCompare) > 0 Then
d1 = Replace(d1, ".", ",", 1, , vbTextCompare)
End If
' Reifenabrieb
ActiveSheet.Cells(8, 13).Value = d1
ElseIf i = 7 And datei > " " Then
d1 = Trim(Mid(datei, 53, 20))
If InStr(1, d1, ".", vbTextCompare) > 0 Then
d1 = Replace(d1, ".", ",", 1, , vbTextCompare)
End If
' Reifenlaufleistung
ActiveSheet.Cells(9, 13).Value = d1
ElseIf i = 8 And datei > " " Then
d1 = Trim(Mid(datei, 16, 20))
' Messrichtung H/R
ActiveSheet.Cells(11, 4).Value = d1
d1 = Trim(Mid(datei, 53, 20))
If InStr(1, d1, ".", vbTextCompare) > 0 Then
d1 = Replace(d1, ".", ",", 1, , vbTextCompare)
End If
' TLuft
'          ActiveSheet.Cells(10, 13).Value = d1
ElseIf i = 9 And datei > " " Then
d1 = Trim(Mid(datei, 16, 20))
If InStr(1, d1, ".", vbTextCompare) > 0 Then
d1 = Replace(d1, ".", ",", 1, , vbTextCompare)
End If
' Von-Station
If Trim(d1) > "" Then
ActiveSheet.Cells(12, 4).Value = CDbl(d1)
End If
d1 = Trim(Mid(datei, 53, 20))
If InStr(1, d1, ".", vbTextCompare) > 0 Then
d1 = Replace(d1, ".", ",", 1, , vbTextCompare)
End If
' TFahrbahn
'          ActiveSheet.Cells(11, 13).Value = d1
ElseIf i = 10 And datei > " " Then
d1 = Trim(Mid(datei, 16, 20))
If InStr(1, d1, ".", vbTextCompare) > 0 Then
d1 = Replace(d1, ".", ",", 1, , vbTextCompare)
End If
' Bis-Station
If Trim(d1) > "" Then
ActiveSheet.Cells(13, 4).Value = CDbl(d1)
End If
d1 = Trim(Mid(datei, 53, 20))
If InStr(1, d1, ".", vbTextCompare) > 0 Then
d1 = Replace(d1, ".", ",", 1, , vbTextCompare)
End If
' TWasser
'          ActiveSheet.Cells(12, 13).Value = d1
ElseIf i = 11 And datei > " " Then
d1 = Trim(Mid(datei, 16, 20))
' Von-NK
ActiveSheet.Cells(14, 4).Value = d1
d1 = Trim(Mid(datei, 53, 20))
' Wetter
ActiveSheet.Cells(14, 13).Value = d1
ElseIf i = 12 And datei > " " Then
d1 = Trim(Mid(datei, 16, 20))
' Bis-NK
ActiveSheet.Cells(15, 4).Value = d1
ElseIf i = 13 And datei > " " Then
d1 = Trim(Mid(datei, 16, 20))
' Fahrstreifen
ActiveSheet.Cells(10, 4).Value = d1
ElseIf i = 14 And datei > " " Then
d1 = Trim(Mid(datei, 53, 20))
' Messfahrzeug
ActiveSheet.Cells(17, 13).Value = d1
ElseIf i = 15 And datei > " " Then
d1 = Trim(Mid(datei, 16, 20))
' Operator
ActiveSheet.Cells(15, 13).Value = d1
d1 = Trim(Mid(datei, 53, 20))
' Fahrer
ActiveSheet.Cells(16, 13).Value = d1
ElseIf i = 16 And datei > " " Then
ii = 1
Do
d1 = Mid(Trim(Mid(datei, 16, 50)), 1, ii)
ii = ii + 1
Loop Until (d1 = "") Or (Mid(Trim(Mid(datei, 16, 50)), ii, 1) = ",")
' Betreiber
'          ActiveSheet.Cells(18, 13).Value = d1
ElseIf i = 19 And datei > " " Then
d1 = Trim(Mid(datei, 16, 50))
' Bemerkungen
ActiveSheet.Cells(21, 4).Value = ActiveSheet.Cells(21, 4).Value + " " + d1
ElseIf i = 20 And datei > " " Then
d1 = Trim(datei)
' Bemerkungen
ActiveSheet.Cells(21, 4).Value = ActiveSheet.Cells(21, 4).Value + " " + d1
ElseIf i = 21 And datei > " " Then
d1 = Trim(Mid(datei, 18, 3))
' Sollabstand
ActiveSheet.Cells(17, 4).Value = d1
ElseIf i = 28 Then
If datei > " " Then
d1 = Trim(Mid(datei, 14, 255))
' Ereignisse
ActiveSheet.Cells(22, 4).Value = ""
For ii = 0 To UBound(Split(d1, ";"))
ReDim Preserve marker(ii)
marker(ii) = Split(d1, ";")(ii)
Next ii
For ii = 0 To UBound(marker)
ActiveSheet.Cells(22, 4).Value = ActiveSheet.Cells(22, 4).Value + Chr(Asc("A") +  _
ii) + " = " + marker(ii)
If ii  26 And i  " " Then
d1 = Trim(datei)
' Bemerkungen
ActiveSheet.Cells(21, 4).Value = ActiveSheet.Cells(21, 4).Value + " " + d1
ElseIf i = 40 Then
ii = 0
ElseIf i > 40 And datei > " " Then
ii = ii + 1
If ii > 5 Then
ActiveSheet.Range("A26:N30").Copy
ActiveSheet.Cells(i - zeilensprung, 1).Activate
ActiveSheet.Paste
ActiveSheet.Range(Cells(i - zeilensprung, 2), Cells(i - zeilensprung + 4, 10)). _
ClearContents
ActiveSheet.Range(Cells(i - zeilensprung, 12), Cells(i - zeilensprung + 4, 13)). _
ClearContents
If (SheetName = "1. Messfahrt") Then
Sheets("Mittelwert").Select
Range(Cells(24, 1), Cells(28, 11)).Select
Selection.Copy
Cells(i - zeilensprung - 2, 1).Activate
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Range(Cells(i - zeilensprung - 2, 9), Cells(i - zeilensprung - 2 + 4,  _
10)).ClearContents
If i - zeilensprung > 32 Then
Sheets("Diagramm-Daten").Select
Range("A3", "M3").Select
Selection.Copy
d2 = d2 + 1
Cells(d2, 1).Activate
ActiveSheet.Paste
Application.CutCopyMode = False
If i - zeilensprung """",Mittelwert!R[" + CStr(i - zeilensprung - 2 - r1) + "]C[1],"""")"
Selection.Offset(0, 1).Activate
ActiveCell.FormulaR1C1 = "=IF('1. Messfahrt'!R[" + CStr(i - zeilensprung - r1) + _
"]C[12]"""",'1. Messfahrt'!R[" + CStr(i - zeilensprung - r1) + "]C[12],"""")"
Selection.Offset(0, 3).Activate
ActiveCell.FormulaR1C1 = "=IF('2. Messfahrt'!R[" + CStr(i - zeilensprung - r1) + _
"]C[10]"""",'2. Messfahrt'!R[" + CStr(i - zeilensprung - r1) + "]C[10],"""")"
Selection.Offset(0, 6).Activate
ActiveCell.FormulaR1C1 = "=IF(Mittelwert!R[" + CStr(i - zeilensprung - 2 - r1) + _
"]C[4]"""",Round(Mittelwert!R[" + CStr(i - zeilensprung - 2 - r1) + "]C[4],2),"""")"
Range("Q4:V4").Select
Selection.Copy
Cells(d3 + d31, 17).Select
Selection.Offset(1, 0).Activate
ActiveSheet.Paste
Selection.Offset(1, 0).Activate
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.Offset(-1, 0).Activate
ActiveCell.Formula = "=A" + CStr(d3 - 1)
ActiveCell.Offset(0, 1).Activate
ActiveCell.Formula = "=B" + CStr(d3)
ActiveCell.Offset(0, 1).Activate
ActiveCell.Formula = "=D" + CStr(d3)
ActiveCell.Offset(1, 0).Activate
ActiveCell.Formula = "=D" + CStr(d3)
ActiveCell.Offset(0, -1).Activate
ActiveCell.Formula = "=B" + CStr(d3)
ActiveCell.Offset(0, -1).Activate
ActiveCell.Formula = "=A" + CStr(d3)
d3 = d3 + 1
d31 = d31 + 1
Sheets("BAST").Select
Range("B24:B25").Select
Selection.Copy
c = c + 1
z = z + 1
If c > 8 Then
c = 1
r = r + 2
End If
Cells(r, c).Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = _
"=IF(MAX('1. Messfahrt'!R" + CStr(i - zeilensprung - 1 - 4) + "C3:R" + CStr(i  _
- zeilensprung - 1) + "C3)>Mittelwert!R17C4+'Diagramm-Daten'!R2C16,CONCATENATE(""" + _
CStr(z) + " "",MAX('1. Messfahrt'!R" + CStr(i - zeilensprung - 1 - 4) + "C3:R" _
+ CStr(i - zeilensprung - 1) + "C3),"" km/h""),IF(AND(MIN('1. Messfahrt'!R" + _
CStr(i - zeilensprung - 1 - 4) + "C3:R" + CStr(i - zeilensprung - 1) + "C3)"""",Mittelwert!R" _
+ CStr(i - zeilensprung - 2 - 1) + "C11,"""")"
Range("A1").Select
End If
Sheets("1. Messfahrt").Select
End If
ii = 1
End If
d1 = Trim(Left(datei, 8))
If InStr(1, d1, ".", 1) > 0 Then
d1 = Trim(Mid(d1, 1, InStr(1, d1, ".", 1) - 1)) + "," + _
Trim(Mid(d1, InStr(1, d1, ".", 1) + 1, Len(d1) - InStr(1, d1, ".", 1)))
End If
Cells(i - zeilensprung, 2).Value = CDbl(d1)
If min_ > CDbl(d1) Then
min_ = CDbl(d1)
End If
If max_  CDbl(d1) Then
Abschnittr = 0.02
Else
Abschnittr = -0.02
End If
End If
If (Abs(km2von + Abschnittr - CDbl(d1)) > 2.0001) Then
If km2anzahl = 0 Then
km2anzahl = 1
End If
If (SheetName = "1. Messfahrt") Then
Sheets("2km-Vergleich").Activate
ActiveSheet.Range("A3:E3").Copy
ActiveSheet.Cells(2 + km2abschnitt, 1).Activate
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Cells(2 + km2abschnitt, 1).Value = km2von + Abschnittr
ActiveSheet.Cells(2 + km2abschnitt, 2).Value = km2bis
ActiveSheet.Cells(2 + km2abschnitt, 3).Value = Round(km2mw / km2anzahl, 3)
ActiveSheet.Range("A3").Select
Sheets(SheetName).Activate
Else
Sheets("2km-Vergleich").Cells(2 + km2abschnitt, 4).Value = Round(km2mw /  _
km2anzahl, 3)
End If
km2von = CDbl(d1)
km2bis = CDbl(d1)
km2abschnitt = km2abschnitt + 1
km2anzahl = 0
km2mw = 0
Else
km2bis = CDbl(d1)
End If
' Ende 2km-Abschnitte bilden
d1 = Trim(Mid(datei, 19, 6))
If InStr(1, d1, ".", 1) > 0 Then
d1 = Trim(Mid(d1, 1, InStr(1, d1, ".", 1) - 1)) + "," + _
Trim(Mid(d1, InStr(1, d1, ".", 1) + 1, Len(d1) - InStr(1, d1, ".", 1)))
End If
Cells(i - zeilensprung, 4).Value = CDbl(d1)
my = CDbl(d1)
d1 = Trim(Mid(datei, 15, 4))
If InStr(1, d1, ".", 1) > 0 Then
d1 = Trim(Mid(d1, 1, InStr(1, d1, ".", 1) - 1)) + "," + _
Trim(Mid(d1, InStr(1, d1, ".", 1) + 1, Len(d1) - InStr(1, d1, ".", 1)))
End If
Cells(i - zeilensprung, 3).Value = CDbl(d1)
vist = CDbl(d1)
d1 = Trim(Mid(datei, 25, 3))
Cells(i - zeilensprung, 6).Value = CDbl(d1)
d1 = Trim(Mid(datei, 28, 3))
Cells(i - zeilensprung, 7).Value = CDbl(d1)
tf = CDbl(d1)
d1 = Trim(Mid(datei, 31, 3))
Cells(i - zeilensprung, 8).Value = CDbl(d1)
tw = CDbl(d1)
km2mw = km2mw + (my + ((vist - vsoll) / 20 * vkorr)) + (tw - 20) * 0.002 + (tf - 20) * _
0.0012
km2anzahl = km2anzahl + 1
d1 = Trim(Mid(datei, 35, 4))
Cells(i - zeilensprung, 13).Value = "N" + d1 + "°"
d1 = Trim(Mid(datei, 39, 2))
Cells(i - zeilensprung, 13).Value = Cells(i - zeilensprung, 13).Value + d1
d1 = Trim(Mid(datei, 42, 6))
d1 = CStr(Int(CDbl("0," + d1) * 60))
If Len(d1)  "" Then
Cells(i - zeilensprung, 5).Value = CDbl(d1)
End If
d1 = Trim(Mid(datei, 83, 2))
If Trim(d1) > "" Then
Cells(i - zeilensprung, 9).Value = CDbl(d1)
End If
d1 = Trim(Mid(datei, 63, 9))
If d1  "" Then
' Ereignisse
Cells(i - zeilensprung, 10).Value = d1
For sc = 1 To Len(d1)
If marker(0)  "" Then
ma = Mid(d1, sc, 1)
sv = Sheets("Mittelwert").Cells(i - zeilensprung - 2, 9).Value Like "*" +  _
marker(Asc(ma) - Asc("A")) + "*"
If sv = False Then
Sheets("Mittelwert").Cells(i - zeilensprung - 2, 9).Value = Sheets(" _
Mittelwert").Cells(i - zeilensprung - 2, 9).Value + " " + marker(Asc(ma) - Asc("A"))
End If
sv = marker(Asc(ma) - Asc("A")) Like "*Baulos*"
Else
sv = Sheets("Mittelwert").Cells(i - zeilensprung - 2, 9).Value Like "*" + d1 + " _
If sv = False Then
Sheets("Mittelwert").Cells(i - zeilensprung - 2, 9).Value = Sheets(" _
Mittelwert").Cells(i - zeilensprung - 2, 9).Value + " " + d1
End If
sv = d1 Like "*Baulos*"
End If
If sv = True Then
If Not Baulos Then
Baulos = True
End If
d4 = d4 + 1
If d4 = 1 Then
Sheets("Diagramm-Daten").Cells(d4, 24).Value = Cells(i - zeilensprung, 2). _
Value - 0.02
Sheets("Diagramm-Daten").Cells(d4, 25).Value = 0.22
d4 = d4 + 1
End If
Sheets("Diagramm-Daten").Cells(d4, 24).Value = Cells(i - zeilensprung, 2).Value
Sheets("Diagramm-Daten").Cells(d4, 25).Value = 0.22
End If
If marker(0)  "" Then
sv = marker(Asc(ma) - Asc("A")) Like "*Brücke*"
Else
sv = d1 Like "*Brücke*"
End If
If sv = True Then
d5 = d5 + 1
If d5 = 1 Then
Sheets("Diagramm-Daten").Cells(d5, 26).Value = Cells(i - zeilensprung, 2). _
Value - 0.02
Sheets("Diagramm-Daten").Cells(d5, 27).Value = 0.24
d5 = d5 + 1
End If
Sheets("Diagramm-Daten").Cells(d5, 26).Value = Cells(i - zeilensprung, 2).Value
Sheets("Diagramm-Daten").Cells(d5, 27).Value = 0.24
Else
If marker(0)  "" Then
sv = (Not (marker(Asc(ma) - Asc("A")) Like "*Baulos*"))
Else
sv = Not d1 Like "*Baulos*"
End If
If sv Then
d6 = d6 + 1
If d6 = 1 Then
Sheets("Diagramm-Daten").Cells(d6, 28).Value = Cells(i - zeilensprung, 2). _
Value - 0.02
Sheets("Diagramm-Daten").Cells(d6, 29).Value = 0.26
d6 = d6 + 1
End If
Sheets("Diagramm-Daten").Cells(d6, 28).Value = Cells(i - zeilensprung, 2). _
Value
Sheets("Diagramm-Daten").Cells(d6, 29).Value = 0.26
End If
End If
If marker(0) = "" Then
sc = Len(d1) + 1
End If
Next
End If
End If
i = i + 1
Loop
f.Close
Application.CutCopyMode = False
' letzten 2km-Abschnitte bilden
If km2anzahl > 1 And _
(((Abschnittr = -0.02) And (Abs(km2bis - min_) > 2)) Or _
((Abschnittr = 0.02) And (Abs(km2bis - max_) > 2))) Then
If Abschnittr  0 Then
Cells(i - zeilensprung - 1, 2).Activate
ActiveCell.Offset(-4, 0).Activate
ra = ActiveCell.Row
Range(Cells(ra, 2), Cells(ra + 4, 10)).Select
Selection.Copy
Cells(i - zeilensprung - ii, 2).Select
ActiveSheet.PasteSpecial Format:=3, Link:=1, DisplayAsIcon:=False, _
IconFileName:=False
Range(Cells(ra, 12), Cells(ra + 4, 13)).Select
Selection.Copy
Cells(i - zeilensprung - ii, 12).Select
ActiveSheet.PasteSpecial Format:=3, Link:=1, DisplayAsIcon:=False, _
IconFileName:=False
Application.CutCopyMode = False
Range(Cells(i - zeilensprung - ii, 1), Cells(i - zeilensprung - ii + 4, 14)).Select
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
For j = 0 To ii - 1
Range(Cells(i - zeilensprung + 4 - ii - j, 1), Cells(i - zeilensprung + 4 - ii - j, 14)) _
.Select
Selection.Interior.ColorIndex = xlNone
Next
Cells(i - zeilensprung + 5 - ii, 1).Select
With Selection
.Value = "Die Werte der grau hinterlegten Zellen füllen den letzten 100m-Abschnitt auf!" _
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Sheets("Mittelwert").Select
Range(Cells(i - zeilensprung - 2 - ii, 1), Cells(i - zeilensprung - 2 - ii + 4, 11)). _
Select
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
For j = 0 To ii - 1
Range(Cells(i - zeilensprung - 2 + 4 - ii - j, 1), Cells(i - zeilensprung - 2 + 4 - ii - _
j, 11)).Select
Selection.Interior.ColorIndex = xlNone
Next
Cells(i - zeilensprung - 2 + 5 - ii, 1).Select
With Selection
.Value = "Die Werte der grau hinterlegten Zellen füllen den letzten 100m-Abschnitt auf!" _
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
For j = 0 To 5 - ii
Cells(i - zeilensprung - 2 - 1 - j, 9).Select
erg = ActiveCell.Value
Cells(i - zeilensprung - 2 - 1 + 5 - ii - j, 9).Select
ActiveCell.FormulaR1C1 = erg
Next
End If
Application.CutCopyMode = False
Sheets("Diagramm-Daten").Select
Range("Q2").Select
If min_ + 0.1 """",RC[-16]+0.1,"""")"
If Sheets("Diagramm-Daten").Cells(1, 24).Value  "" Then
Sheets("Diagramm-Daten").Cells(1, 24).Value = Sheets("Diagramm-Daten").Cells(1, 24). _
Value + 0.04
End If
If Sheets("Diagramm-Daten").Cells(1, 26).Value  "" Then
Sheets("Diagramm-Daten").Cells(1, 26).Value = Sheets("Diagramm-Daten").Cells(1, 26). _
Value + 0.04
End If
Else
max_1 = max_
If min_1  8 Then
c = 1
r = r + 2
End If
Cells(r, c).Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = _
"=IF(MAX('1. Messfahrt'!R" + CStr(i - zeilensprung - 1 - 4) + "C3:R" + CStr(i -  _
zeilensprung - 1) + "C3)>Mittelwert!R17C4+'Diagramm-Daten'!R2C16,CONCATENATE(""" + _
CStr(z) + " "",MAX('1. Messfahrt'!R" + CStr(i - zeilensprung - 1 - 4) + "C3:R" + CStr(i  _
- zeilensprung - 1) + "C3),"" km/h""),IF(AND(MIN('1. Messfahrt'!R" + _
CStr(i - zeilensprung - 1 - 4) + "C3:R" + CStr(i - zeilensprung - 1) + "C3)"""",Mittelwert!R" + CStr(i  _
- zeilensprung - 2 - 1) + "C11,"""")"
Range("A1").Select
End If
Sheets("Messfahrtenvergleich").Select
ActiveSheet.ChartObjects("Diagramm 1025").Activate
ActiveChart.PlotArea.Select
If (SheetName = "1. Messfahrt") Then
ActiveChart.SeriesCollection(1).XValues = "='1. Messfahrt'!R26C2:R" + CStr(i -  _
zeilensprung - 1) + "C2"
ActiveChart.SeriesCollection(1).Values = "='1. Messfahrt'!R26C11:R" + CStr(i -  _
zeilensprung - 1) + "C11"
Else
ActiveChart.SeriesCollection(2).XValues = "='2. Messfahrt'!R26C2:R" + CStr(i -  _
zeilensprung - 1) + "C2"
ActiveChart.SeriesCollection(2).Values = "='2. Messfahrt'!R26C11:R" + CStr(i -  _
zeilensprung - 1) + "C11"
End If
ActiveChart.Axes(xlCategory).Select
With ActiveChart.Axes(xlCategory)
.MinimumScale = min_1
.MaximumScale = max_1
.MinorUnitIsAuto = False
.MajorUnitIsAuto = False
.Crosses = xlCustom
.CrossesAt = .MinimumScale
.MinorUnit = 0.05
.MajorUnit = 0.1
.ReversePlotOrder = False
.ScaleType = xlLinear
End With
d3 = d3 + d31
If d3 > ds Then
d36 = d3
Else
d36 = ds
End If
ActiveSheet.ChartObjects("Diagramm 1026").Activate
ActiveChart.PlotArea.Select
ActiveChart.SeriesCollection(1).XValues = "='Diagramm-Daten'!R2C17:R" + CStr(d36) + "C17"
ActiveChart.SeriesCollection(1).Values = "='Diagramm-Daten'!R2C18:R" + CStr(d36) + "C18"
If Sheets("Diagramm-Daten").Cells(3, 19).Value  "" Then
ActiveChart.SeriesCollection(2).XValues = "='Diagramm-Daten'!R2C17:R" + CStr(d36) + "C17"
ActiveChart.SeriesCollection(2).Values = "='Diagramm-Daten'!R2C19:R" + CStr(d36) + "C19"
End If
ActiveChart.Axes(xlCategory).Select
With ActiveChart.Axes(xlCategory)
.MinimumScale = min_1
.MaximumScale = max_1
.MinorUnitIsAuto = False
.MajorUnitIsAuto = False
.Crosses = xlCustom
.CrossesAt = .MinimumScale
.MinorUnit = 0.05
.MajorUnit = 0.1
.ReversePlotOrder = False
.ScaleType = xlLinear
End With
Range("E31").Select
Sheets("Diagramm").Select
ActiveSheet.ChartObjects("Diagramm 1").Activate
If (d4 > d4a) Then
d4a = d4
ActiveChart.SeriesCollection(4).XValues = "='Diagramm-Daten'!R1C24:R" + CStr(d4) + "C24"
ActiveChart.SeriesCollection(4).Values = "='Diagramm-Daten'!R1C25:R" + CStr(d4) + "C25"
End If
If (d5 > d5a) Then
d5a = d5
ActiveChart.SeriesCollection(5).XValues = "='Diagramm-Daten'!R1C26:R" + CStr(d5) + "C26"
ActiveChart.SeriesCollection(5).Values = "='Diagramm-Daten'!R1C27:R" + CStr(d5) + "C27"
End If
If (d6 > d6a) Then
d6a = d6
ActiveChart.SeriesCollection(6).XValues = "='Diagramm-Daten'!R1C28:R" + CStr(d6) + "C28"
ActiveChart.SeriesCollection(6).Values = "='Diagramm-Daten'!R1C29:R" + CStr(d6) + "C29"
End If
If (SheetName = "1. Messfahrt") Or (d3 > ds) Then
If (d3 > ds) Then
ds = d3
End If
prange = "='Diagramm-Daten'!R2C17:R" + CStr(d3) + "C17"
ActiveChart.SeriesCollection(1).XValues = prange
ActiveChart.SeriesCollection(2).XValues = prange
ActiveChart.SeriesCollection(3).XValues = prange
prange = "='Diagramm-Daten'!R2C22:R" + CStr(d3) + "C22"
ActiveChart.SeriesCollection(1).Values = prange
prange = "='Diagramm-Daten'!R2C20:R" + CStr(d3) + "C20"
ActiveChart.SeriesCollection(2).Values = prange
prange = "='Diagramm-Daten'!R2C21:R" + CStr(d3) + "C21"
ActiveChart.SeriesCollection(3).Values = prange
ActiveChart.Axes(xlCategory).Select
With ActiveChart.Axes(xlCategory)
.MinimumScale = min_1
.MaximumScale = max_1
.MinorUnitIsAuto = False
.MajorUnitIsAuto = False
.Crosses = xlCustom
.CrossesAt = .MinimumScale
.MinorUnit = 0.05
.MajorUnit = 0.1
.ReversePlotOrder = False
.ScaleType = xlLinear
End With
End If
End If
Range("H1").Select
Sheets("Mittelwert").Select
Range("J7").Select
If Baulos And (SheetName = "2. Messfahrt") Then
Baulose
End If
Sheets(SheetName).Select
Range("F1").Select
End If
End If
Application.ScreenUpdating = True
End Sub

Sub Baulose()
' Baulose Makro
Dim Baulos As Boolean
Dim Diagrammzeile%, Brueckenzeile%, Ereigniszeile%, Losnummer%, NeueZeile%, Zeile%, Zeilen As  _
Integer
Losnummer = 0
Baulos = False
Sheets("Mittelwert").Select
Zeile = 24
ActiveSheet.Cells(Zeile, 1).Select
Do While Sheets("Mittelwert").Cells(Zeile, 2).Value  ""
If Sheets("Mittelwert").Cells(Zeile, 1).Interior.ColorIndex  15 Then
sv = Sheets("Mittelwert").Cells(Zeile, 9).Value Like "*Baulos*"
If sv = True Then
If Not Baulos Then
Losnummer = Losnummer + 1
Baulos = True
NeueZeile = 23
Zeilen = 0
Diagrammzeile = 0
Brueckenzeile = 1
Ereigniszeile = 1
min_b = 100000000
max_b = -100000000
Sheets(Array("Mittelwert Baulos", "Diagramm Baulos")).Select
Sheets(Array("Mittelwert Baulos", "Diagramm Baulos")).Copy Before:=Sheets("BAST")
Sheets("Mittelwert Baulos (2)").Select
ActiveSheet.Name = "Mittelwert Baulos " + CStr(Losnummer)
ActiveSheet.PageSetup.LeftHeader = "&""Arial,Fett""&12Anlage 1." + CStr(4 + Losnummer * 2) _
+ " / Blatt &P"
Sheets("Diagramm Baulos (2)").Select
ActiveSheet.Name = "Diagramm Baulos " + CStr(Losnummer)
Range("N1:N29").Select
ActiveCell.FormulaR1C1 = _
"=CONCATENATE(""Anlage 1." + CStr(5 + Losnummer * 2) + " zum Untersuchungsbefund Nr. "", _
'1. Messfahrt'!RC[-7])"
Range("H1").Select
End If
NeueZeile = NeueZeile + 1
Zeilen = Zeilen + 1
If Zeilen > 5 Then
Zeilen = 1
Sheets("Mittelwert Baulos " + CStr(Losnummer)).Select
Range(Cells(24, 1), Cells(28, 11)).Select
Selection.Copy
Cells(NeueZeile, 1).Activate
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Range(Cells(NeueZeile, 2), Cells(NeueZeile + 4, 3)).ClearContents
ActiveSheet.Range(Cells(NeueZeile, 5), Cells(NeueZeile + 4, 5)).ClearContents
ActiveSheet.Range(Cells(NeueZeile, 9), Cells(NeueZeile + 4, 10)).ClearContents
Diagrammzeile = Diagrammzeile + 2
Sheets("Diagramm Baulos " + CStr(Losnummer)).Select
sa = Sheets("Mittelwert Baulos " + CStr(Losnummer)).Cells(NeueZeile - 1, 1).Value
se = Sheets("Mittelwert Baulos " + CStr(Losnummer)).Cells(NeueZeile - 1, 2).Value
If Diagrammzeile = 0 Then
Diagrammzeile = 2
End If
If Diagrammzeile = 2 Then
Cells(Diagrammzeile, 16).Value = Round(se - ((se - sa) * 5), 3)
Else
Cells(Diagrammzeile, 16).Value = Cells(Diagrammzeile - 1, 16).Value
End If
Cells(Diagrammzeile, 17).Value = Sheets("Mittelwert Baulos " + CStr(Losnummer)).Cells( _
NeueZeile - 1, 11).Value
Range("R2:T2").Select
Selection.Copy
Cells(Diagrammzeile, 18).Select
ActiveSheet.Paste
Cells(Diagrammzeile + 1, 18).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Cells(Diagrammzeile + 1, 20).ClearContents
Cells(Diagrammzeile + 1, 16).Value = Sheets("Mittelwert Baulos " + CStr(Losnummer)).Cells( _
NeueZeile - 1, 2).Value
Cells(Diagrammzeile + 1, 17).Value = Sheets("Mittelwert Baulos " + CStr(Losnummer)).Cells( _
NeueZeile - 1, 11).Value
Cells(Diagrammzeile, 21).Value = 0.22
Cells(Diagrammzeile + 1, 21).Value = 0.22
End If
Sheets("Mittelwert Baulos " + CStr(Losnummer)).Cells(NeueZeile, 2).Value = Sheets(" _
Mittelwert").Cells(Zeile, 2).Value
If NeueZeile > 24 Then
If min_b > Sheets("Mittelwert Baulos " + CStr(Losnummer)).Cells(NeueZeile - 1, 1).Value  _
Then
min_b = Sheets("Mittelwert Baulos " + CStr(Losnummer)).Cells(NeueZeile - 1, 1).Value
End If
If min_b > Sheets("Mittelwert Baulos " + CStr(Losnummer)).Cells(NeueZeile - 1, 2).Value  _
Then
min_b = Sheets("Mittelwert Baulos " + CStr(Losnummer)).Cells(NeueZeile - 1, 2).Value
End If
If max_b  "" And InStr(ma, "Baulos") > 0 Then
ma = Mid(ma, 1, InStr(ma, "Baulos") - 1) + Mid(ma, InStr(ma, "Baulos") + 6, Len(ma) -  _
InStr(ma, "Baulos") - 5)
End If
If Trim(ma) > "" And InStr(ma, "Brücke") > 0 Then
ma = Mid(ma, 1, InStr(ma, "Brücke") - 1) + Mid(ma, InStr(ma, "Brücke") + 6, Len(ma) -  _
InStr(ma, "Brücke") - 5)
End If
If Trim(ma) > "" Then
Ereigniszeile = Ereigniszeile + 1
Sheets("Diagramm Baulos " + CStr(Losnummer)).Cells(Ereigniszeile, 25).Value = Sheets(" _
Mittelwert Baulos " + CStr(Losnummer)).Cells(NeueZeile, 2).Value
Sheets("Diagramm Baulos " + CStr(Losnummer)).Cells(Ereigniszeile, 26).Value = 0.26
End If
Else
If Baulos Then
Baulos = False
Sheets("Mittelwert Baulos " + CStr(Losnummer)).Select
If min_b > Sheets("Mittelwert Baulos " + CStr(Losnummer)).Cells(NeueZeile, 1).Value Then
min_b = Sheets("Mittelwert Baulos " + CStr(Losnummer)).Cells(NeueZeile, 1).Value
End If
If min_b > Sheets("Mittelwert Baulos " + CStr(Losnummer)).Cells(NeueZeile, 2).Value Then
min_b = Sheets("Mittelwert Baulos " + CStr(Losnummer)).Cells(NeueZeile, 2).Value
End If
If max_b  28 Then
ActiveSheet.Cells(NeueZeile, 2).Activate
ActiveCell.Offset(-4, 0).Activate
ra = ActiveCell.Row
Range(Cells(ra, 2), Cells(ra + 4, 3)).Select
Selection.Copy
Cells(NeueZeile - Zeilen + 1, 2).Select
ActiveSheet.PasteSpecial Format:=3, Link:=1, DisplayAsIcon:=False, _
IconFileName:=False
Range(Cells(ra, 5), Cells(ra + 4, 5)).Select
Selection.Copy
Cells(NeueZeile - Zeilen + 1, 5).Select
ActiveSheet.PasteSpecial Format:=3, Link:=1, DisplayAsIcon:=False, _
IconFileName:=False
Application.CutCopyMode = False
Range(Cells(NeueZeile - Zeilen + 1, 1), Cells(NeueZeile - Zeilen + 5, 11)).Select
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
For j = 0 To Zeilen - 1
Range(Cells(NeueZeile - Zeilen + 5 - j, 1), Cells(NeueZeile - Zeilen + 5 - j, 11)). _
Select
Selection.Interior.ColorIndex = xlNone
Next
For j = 0 To 4
erg = Cells(NeueZeile - j, 9).Value
Cells(NeueZeile + 5 - Zeilen - j, 9).Select
ActiveCell.FormulaR1C1 = erg
Next
Cells(NeueZeile - Zeilen + 6, 1).Select
With Selection
.Value = "Die Werte der grau hinterlegten Zellen füllen den letzten 100m-Abschnitt  _
auf!"
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Diagrammzeile = Diagrammzeile + 2
End If
Range("G2").Select
If Zeilen  1) Then
ActiveChart.SeriesCollection(5).XValues = "='Diagramm Baulos " + CStr(Losnummer) + "'! _
R2C22:R" + CStr(Brueckenzeile) + "C22"
ActiveChart.SeriesCollection(5).Values = "='Diagramm Baulos " + CStr(Losnummer) + "'! _
R2C23:R" + CStr(Brueckenzeile) + "C23"
End If
If (Ereigniszeile > 1) Then
ActiveChart.SeriesCollection(6).XValues = "='Diagramm Baulos " + CStr(Losnummer) + "'! _
R2C25:R" + CStr(Ereigniszeile) + "C25"
ActiveChart.SeriesCollection(6).Values = "='Diagramm Baulos " + CStr(Losnummer) + "'! _
R2C26:R" + CStr(Ereigniszeile) + "C26"
End If
ActiveChart.Axes(xlCategory).Select
With ActiveChart.Axes(xlCategory)
.MinimumScale = min_b
.MaximumScale = max_b
.MinorUnitIsAuto = False
.MajorUnitIsAuto = False
.Crosses = xlCustom
.CrossesAt = .MinimumScale
.MinorUnit = 0.2
.MajorUnit = 0.5
.ReversePlotOrder = False
.ScaleType = xlLinear
End With
Application.CutCopyMode = False
Range("H1").Select
End If
End If
End If
Zeile = Zeile + 1
Loop
' Baulos bis Dateiende
If Baulos Then
Baulos = False
Sheets("Mittelwert Baulos " + CStr(Losnummer)).Select
If min_b > Sheets("Mittelwert Baulos " + CStr(Losnummer)).Cells(NeueZeile, 1).Value Then
min_b = Sheets("Mittelwert Baulos " + CStr(Losnummer)).Cells(NeueZeile, 1).Value
End If
If min_b > Sheets("Mittelwert Baulos " + CStr(Losnummer)).Cells(NeueZeile, 2).Value Then
min_b = Sheets("Mittelwert Baulos " + CStr(Losnummer)).Cells(NeueZeile, 2).Value
End If
If max_b  28 Then
ActiveSheet.Cells(NeueZeile, 2).Activate
ActiveCell.Offset(-4, 0).Activate
ra = ActiveCell.Row
Range(Cells(ra, 2), Cells(ra + 4, 3)).Select
Selection.Copy
Cells(NeueZeile - Zeilen + 1, 2).Select
ActiveSheet.PasteSpecial Format:=3, Link:=1, DisplayAsIcon:=False, _
IconFileName:=False
Range(Cells(ra, 5), Cells(ra + 4, 5)).Select
Selection.Copy
Cells(NeueZeile - Zeilen + 1, 5).Select
ActiveSheet.PasteSpecial Format:=3, Link:=1, DisplayAsIcon:=False, _
IconFileName:=False
Application.CutCopyMode = False
Range(Cells(NeueZeile - Zeilen + 1, 1), Cells(NeueZeile - Zeilen + 5, 11)).Select
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
For j = 0 To Zeilen - 1
Range(Cells(NeueZeile - Zeilen + 5 - j, 1), Cells(NeueZeile - Zeilen + 5 - j, 11)). _
Select
Selection.Interior.ColorIndex = xlNone
Next
For j = 0 To 4
erg = Cells(NeueZeile - j, 9).Value
Cells(NeueZeile + 5 - Zeilen - j, 9).Select
ActiveCell.FormulaR1C1 = erg
Next
Cells(NeueZeile - Zeilen + 6, 1).Select
With Selection
.Value = "Die Werte der grau hinterlegten Zellen füllen den letzten 100m-Abschnitt  _
auf!"
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Diagrammzeile = Diagrammzeile + 2
End If
Range("G2").Select
If Zeilen  1) Then
ActiveChart.SeriesCollection(5).XValues = "='Diagramm Baulos " + CStr(Losnummer) + "'! _
R2C22:R" + CStr(Brueckenzeile) + "C22"
ActiveChart.SeriesCollection(5).Values = "='Diagramm Baulos " + CStr(Losnummer) + "'! _
R2C23:R" + CStr(Brueckenzeile) + "C23"
End If
If (Ereigniszeile > 1) Then
ActiveChart.SeriesCollection(6).XValues = "='Diagramm Baulos " + CStr(Losnummer) + "'! _
R2C25:R" + CStr(Ereigniszeile) + "C25"
ActiveChart.SeriesCollection(6).Values = "='Diagramm Baulos " + CStr(Losnummer) + "'! _
R2C26:R" + CStr(Ereigniszeile) + "C26"
End If
ActiveChart.Axes(xlCategory).Select
With ActiveChart.Axes(xlCategory)
.MinimumScale = min_b
.MaximumScale = max_b
.MinorUnitIsAuto = False
.MajorUnitIsAuto = False
.Crosses = xlCustom
.CrossesAt = .MinimumScale
.MinorUnit = 0.05
.MajorUnit = 0.1
.ReversePlotOrder = False
.ScaleType = xlLinear
End With
Application.CutCopyMode = False
Range("H1").Select
End If
End Sub