|
Application.Goto Reference:="Reifentabelle"
Workbooks.OpenText Filename:= _
"C:\CTT\Public\scripts\Leistungsprüfstand\Reifentabelle.txt", Origin:=xlMSDOS _
, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 2), Array(2, 1), _
Array(3, 2), Array(4, 1)), TrailingMinusNumbers:=True
Range("A:A,C:C").Select
Range("C1").Activate
Selection.NumberFormat = "@"
Range("B:B,D:D").Select
Range("D1").Activate
Selection.NumberFormat = "General"
Range("A1").Select
Dim Wheel, Value, Axle, x, y, z, MW, yx, zx, a
Axle = MsgBox("Reifen Vorderachse?", 4, "VA")
If Axle = vbYes Then
y = 0
z = 1
Do
x = Cells(z, 1).Value
If x = istleer Then
y = 1
Else
z = z + 1
End If
Loop While y = 0
y = 0
Do
Wheel = InputBox("Bitte geben sie den neuen Merkmalswert ein!", "Merkmalswert", "Merkmalswert")
'gibt es den MW schon?
yx = 0
MW = 1
a = 0
Do
x = Cells(MW, 1).Value
If x = Wheel Or x = istleer Then
If x = Wheel Then
x = MsgBox("Merkmalswert ist schon vorhanden! Radius ändern?", 4, "Frage")
If x = vbYes Then
a = 1
zx = z
z = MW
End If
If x = vbYes Then GoTo InputRadius
If x = vbNo Then
z = z - 1
End If
If x = vbNo Then GoTo weitereReifen
End If
yx = 1
Else
MW = MW + 1
End If
Loop While yx = 0
InputRadius:
Value = InputBox("Bitte geben sie den Reifenradius ein", "Reifenradius", "Reifenradius in m")
Cells(z, 1).Select
ActiveCell.FormulaR1C1 = Wheel
Cells(z, 2).Select
ActiveCell.FormulaR1C1 = Value
If a = 1 Then
z = zx - 1
End If
weitereReifen:
x = MsgBox("Weitere Reifen hinzufügen?", 4, "Frage")
If x = vbYes Then
y = 0
z = z + 1
Else
y = 1
End If
Loop While y = 0
Range(Cells(2, 1), Cells(z, 2)).Select
ActiveWorkbook.Worksheets("Reifentabelle").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Reifentabelle").Sort.SortFields.Add Key:= _
Range("A2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Reifentabelle").Sort
.SetRange Range(Cells(2, 1), Cells(z, 2))
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End If
Axle = MsgBox("Reifen Hinterachse?", 4, "HA")
If Axle = vbYes Then
y = 0
z = 1
Do
x = Cells(z, 3).Value
If x = istleer Then
y = 1
Else
z = z + 1
End If
Loop While y = 0
y = 0
Do
Wheel = InputBox("Bitte geben sie den neuen Merkmalswert ein!", "Merkmalswert", "Merkmalswert")
'gibt es den MW schon?
yx = 0
MW = 1
a = 0
Do
x = Cells(MW, 3).Value
If x = Wheel Or x = istleer Then
If x = Wheel Then
x = MsgBox("Merkmalswert ist schon vorhanden! Radius ändern?", 4, "Frage")
If x = vbYes Then
a = 1
zx = z
z = MW
End If
If x = vbYes Then GoTo InputRadiusHA
If x = vbNo Then
z = z - 1
End If
If x = vbNo Then GoTo weitereReifenHA
End If
yx = 1
Else
MW = MW + 1
End If
Loop While yx = 0
InputRadiusHA:
Value = InputBox("Bitte geben sie den Reifenradius ein", "Reifenradius", "Reifenradius in m")
Cells(z, 3).Select
ActiveCell.FormulaR1C1 = Wheel
Cells(z, 4).Select
ActiveCell.FormulaR1C1 = Value
If a = 1 Then
z = zx - 1
End If
weitereReifenHA:
x = MsgBox("Weitere Reifen hinzufügen?", 4, "Frage")
If x = vbYes Then
y = 0
z = z + 1
Else
y = 1
End If
Loop While y = 0
Range(Cells(2, 3), Cells(z, 4)).Select
ActiveWorkbook.Worksheets("Reifentabelle").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Reifentabelle").Sort.SortFields.Add Key:= _
Range("C2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Reifentabelle").Sort
.SetRange Range(Cells(2, 3), Cells(z, 4))
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End If
x = MsgBox("Änderungen speichern?", 4, "Speichern")
If x = vbYes Then
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:= _
"C:\CTT\Public\scripts\Leistungsprüfstand\Reifentabelle.txt", _
FileFormat:=xlText, CreateBackup:=False
Application.DisplayAlerts = True
End If
Application.DisplayAlerts = False
ActiveWorkbook.Close SaveChanges = False
Application.DisplayAlerts = True
Application.DisplayAlerts = False
ActiveWorkbook.Close SaveChanges = False
Application.DisplayAlerts = True
End Sub |