Macro kürzen????
29.04.2005 19:30:10
Rene
Habe mir dieses Macro mit dem Macrorecorder erstellt:
Option Explicit
Sub Toleranz_02()
Dim p As Single
Dim minWert As Single
Dim maxWert As Single
Dim Zeile As Long
Dim a As Single, b As Single, c As Single, d As Single, e As Single, f As Single, g As Single
Dim h As Single, i As Single, j As Single, k As Single, l As Single, m As Single, n As Single
Application.ScreenUpdating = False 'Bildschirm Aktualisierung ausschalten
'MP000
Sheets("Messauswertung").Select
With ActiveSheet.QueryTables.Add(Connection:="TEXT;C:\DQM\Messung\MP000.DAT" _
, Destination:=Range("A1"))
.name = "MP000"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlFixedWidth
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(2, 2, 2, 2)
.TextFileFixedColumnWidths = Array(20, 15, 15)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
ActiveWindow.SmallScroll Down:=-6
'zentrieren
Cells.Select
Range("A64").Activate
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.NumberFormat = "0.00"
End With
'Punkt mit Komma ersetzen um zu rechnen
Cells.Select
Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Range("A1").Select
'löscht die ersten 147 Zeilen
For Zeile = 147 To 1 Step -1
Rows(Zeile).Delete Shift:=xlUp
Next
' vergleicht Soll und Ist Kurve und schreibt Diff in Spalte D
p = 1
While ActiveSheet.Cells(p, 2).Value <> "" And ActiveSheet.Cells(p, 3).Value <> ""
Cells(p, 4).Value = Cells(p, 2).Value - Cells(p, 3)
p = p + 1
Wend
' löscht die Zeile mit 17,1 und schreibt Min und Max hin
Selection.ClearContents
Range("B1").Select
Selection.ClearContents
Range("C1").Select
Selection.ClearContents
Range("D1").Select
Selection.ClearContents
Range("E1").Select
ActiveCell.FormulaR1C1 = "MinWert"
Range("F1").Select
ActiveCell.FormulaR1C1 = "MaxWert"
Range("F2").Select
'berechnet min\max von Y+17 bis Y+5
minWert = WorksheetFunction.Min(Range("D2:D122"))
Range("E2") = minWert
maxWert = WorksheetFunction.Max(Range("D2:D122"))
Range("F2") = maxWert
'berechnet min\max von Y+5 bis Y 0
minWert = WorksheetFunction.Min(Range("D123:D172"))
Range("E123") = minWert
maxWert = WorksheetFunction.Max(Range("D123:D172"))
Range("F123") = maxWert
'berechnet min\max von Y 0 bis Y-5
minWert = WorksheetFunction.Min(Range("D173:D222"))
Range("E173") = minWert
maxWert = WorksheetFunction.Max(Range("D173:D222"))
Range("F173") = maxWert
'berechnet min\max von Y-5 bis Y-15
minWert = WorksheetFunction.Min(Range("D223:D322"))
Range("E223") = minWert
maxWert = WorksheetFunction.Max(Range("D223:D322"))
Range("F223") = maxWert
'berechnet min\max von Y-15 bis Y-25
minWert = WorksheetFunction.Min(Range("D323:D422"))
Range("E323") = minWert
maxWert = WorksheetFunction.Max(Range("D323:D422"))
Range("F323") = maxWert
'berechnet min\max von Y-25 bis Y-30
minWert = WorksheetFunction.Min(Range("D423:D473"))
Range("E423") = minWert
maxWert = WorksheetFunction.Max(Range("D423:D473"))
Range("F423") = maxWert
'berechnet min\max von Y-30 bis Y-35,7
minWert = WorksheetFunction.Min(Range("D474:D529"))
Range("E474") = minWert
maxWert = WorksheetFunction.Max(Range("D474:D529"))
Range("F474") = maxWert
'Prüft ob in der Toleranz
If Range("E2") >= -0.26 And Range("F2") >= 0.08 _
Or Range("E123") >= -0.03 And Range("F123") >= 0.03 _
Or Range("E173") >= -0.09 And Range("F173") >= 0.09 _
Or Range("E223") >= -0.18 And Range("F223") >= 0.18 _
Or Range("E323") >= -0.19 And Range("F323") >= 0.19 _
Or Range("E423") >= -0.21 And Range("F423") >= 0.21 _
Or Range("E474") >= -0.16 And Range("F474") >= 0.16 Then
'MsgBox "Wert " & minWert & " oder " & maxWert & " zu Hoch"
Sheets("Liste").Range("G7").ClearContents
Else
Exit Sub
End If
' löscht den Inhalt von Tabelle "Messauswertung"
Cells.Select
Selection.ClearContents
Range("F8").Select
'MP001
Sheets("Messauswertung").Select
With ActiveSheet.QueryTables.Add(Connection:="TEXT;C:\DQM\Messung\MP001.DAT" _
, Destination:=Range("A1"))
.name = "MP001"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlFixedWidth
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(2, 2, 2, 2)
.TextFileFixedColumnWidths = Array(20, 15, 15)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
ActiveWindow.SmallScroll Down:=-6
'zentrieren
Cells.Select
Range("A64").Activate
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.NumberFormat = "0.00"
End With
'Punkt mit Komma ersetzen um zu rechnen
Cells.Select
Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Range("A1").Select
'löscht die ersten 147 Zeilen
For Zeile = 147 To 1 Step -1
Rows(Zeile).Delete Shift:=xlUp
Next
' vergleicht Soll und Ist Kurve und schreibt Diff in Spalte D
p = 1
While ActiveSheet.Cells(p, 2).Value <> "" And ActiveSheet.Cells(p, 3).Value <> ""
Cells(p, 4).Value = Cells(p, 2).Value - Cells(p, 3)
p = p + 1
Wend
' löscht die Zeile mit 17,1 und schreibt Min und Max hin
Selection.ClearContents
Range("B1").Select
Selection.ClearContents
Range("C1").Select
Selection.ClearContents
Range("D1").Select
Selection.ClearContents
Range("E1").Select
ActiveCell.FormulaR1C1 = "MinWert"
Range("F1").Select
ActiveCell.FormulaR1C1 = "MaxWert"
Range("F2").Select
'berechnet min\max von Y+17 bis Y+5
minWert = WorksheetFunction.Min(Range("D2:D122"))
Range("E2") = minWert
maxWert = WorksheetFunction.Max(Range("D2:D122"))
Range("F2") = maxWert
'berechnet min\max von Y+5 bis Y 0
minWert = WorksheetFunction.Min(Range("D123:D172"))
Range("E123") = minWert
maxWert = WorksheetFunction.Max(Range("D123:D172"))
Range("F123") = maxWert
'berechnet min\max von Y 0 bis Y-5
minWert = WorksheetFunction.Min(Range("D173:D222"))
Range("E173") = minWert
maxWert = WorksheetFunction.Max(Range("D173:D222"))
Range("F173") = maxWert
'berechnet min\max von Y-5 bis Y-15
minWert = WorksheetFunction.Min(Range("D223:D322"))
Range("E223") = minWert
maxWert = WorksheetFunction.Max(Range("D223:D322"))
Range("F223") = maxWert
'berechnet min\max von Y-15 bis Y-25
minWert = WorksheetFunction.Min(Range("D323:D422"))
Range("E323") = minWert
maxWert = WorksheetFunction.Max(Range("D323:D422"))
Range("F323") = maxWert
'berechnet min\max von Y-25 bis Y-30
minWert = WorksheetFunction.Min(Range("D423:D473"))
Range("E423") = minWert
maxWert = WorksheetFunction.Max(Range("D423:D473"))
Range("F423") = maxWert
'berechnet min\max von Y-30 bis Y-35,7
minWert = WorksheetFunction.Min(Range("D474:D529"))
Range("E474") = minWert
maxWert = WorksheetFunction.Max(Range("D474:D529"))
Range("F474") = maxWert
'Prüft ob in der Toleranz
If Range("E2") >= -0.26 And Range("F2") >= 0.08 _
Or Range("E123") >= -0.03 And Range("F123") >= 0.03 _
Or Range("E173") >= -0.09 And Range("F173") >= 0.09 _
Or Range("E223") >= -0.18 And Range("F223") >= 0.18 _
Or Range("E323") >= -0.19 And Range("F323") >= 0.19 _
Or Range("E423") >= -0.21 And Range("F423") >= 0.21 _
Or Range("E474") >= -0.16 And Range("F474") >= 0.16 Then
'MsgBox "Wert " & minWert & " oder " & maxWert & " zu Hoch"
Sheets("Liste").Range("G8").ClearContents
Else
Exit Sub
End If
' löscht den Inhalt von Tabelle "Messauswertung"
Cells.Select
Selection.ClearContents
Range("F8").Select
'MP079
Sheets("Messauswertung").Select
With ActiveSheet.QueryTables.Add(Connection:="TEXT;C:\DQM\Messung\MP079.DAT" _
, Destination:=Range("A1"))
.name = "MP000"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlFixedWidth
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(2, 2, 2, 2)
.TextFileFixedColumnWidths = Array(20, 15, 15)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
ActiveWindow.SmallScroll Down:=-6
'zentrieren
Cells.Select
Range("A64").Activate
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.NumberFormat = "0.00"
End With
'Punkt mit Komma ersetzen um zu rechnen
Cells.Select
Selection.Replace What:=".", Replacement:=",", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Range("A1").Select
'löscht die ersten 147 Zeilen
For Zeile = 147 To 1 Step -1
Rows(Zeile).Delete Shift:=xlUp
Next
' vergleicht Soll und Ist Kurve und schreibt Diff in Spalte D
p = 1
While ActiveSheet.Cells(p, 2).Value <> "" And ActiveSheet.Cells(p, 3).Value <> ""
Cells(p, 4).Value = Cells(p, 2).Value - Cells(p, 3)
p = p + 1
Wend
' löscht die Zeile mit 17,1 und schreibt Min und Max hin
Selection.ClearContents
Range("B1").Select
Selection.ClearContents
Range("C1").Select
Selection.ClearContents
Range("D1").Select
Selection.ClearContents
Range("E1").Select
ActiveCell.FormulaR1C1 = "MinWert"
Range("F1").Select
ActiveCell.FormulaR1C1 = "MaxWert"
Range("F2").Select
'berechnet min\max von Y+17 bis Y+5
minWert = WorksheetFunction.Min(Range("D2:D122"))
Range("E2") = minWert
maxWert = WorksheetFunction.Max(Range("D2:D122"))
Range("F2") = maxWert
'berechnet min\max von Y+5 bis Y 0
minWert = WorksheetFunction.Min(Range("D123:D172"))
Range("E123") = minWert
maxWert = WorksheetFunction.Max(Range("D123:D172"))
Range("F123") = maxWert
'berechnet min\max von Y 0 bis Y-5
minWert = WorksheetFunction.Min(Range("D173:D222"))
Range("E173") = minWert
maxWert = WorksheetFunction.Max(Range("D173:D222"))
Range("F173") = maxWert
'berechnet min\max von Y-5 bis Y-15
minWert = WorksheetFunction.Min(Range("D223:D322"))
Range("E223") = minWert
maxWert = WorksheetFunction.Max(Range("D223:D322"))
Range("F223") = maxWert
'berechnet min\max von Y-15 bis Y-25
minWert = WorksheetFunction.Min(Range("D323:D422"))
Range("E323") = minWert
maxWert = WorksheetFunction.Max(Range("D323:D422"))
Range("F323") = maxWert
'berechnet min\max von Y-25 bis Y-30
minWert = WorksheetFunction.Min(Range("D423:D473"))
Range("E423") = minWert
maxWert = WorksheetFunction.Max(Range("D423:D473"))
Range("F423") = maxWert
'berechnet min\max von Y-30 bis Y-35,7
minWert = WorksheetFunction.Min(Range("D474:D529"))
Range("E474") = minWert
maxWert = WorksheetFunction.Max(Range("D474:D529"))
Range("F474") = maxWert
'Prüft ob in der Toleranz
If Range("E2") >= -0.26 And Range("F2") >= 0.08 _
Or Range("E123") >= -0.03 And Range("F123") >= 0.03 _
Or Range("E173") >= -0.09 And Range("F173") >= 0.09 _
Or Range("E223") >= -0.18 And Range("F223") >= 0.18 _
Or Range("E323") >= -0.19 And Range("F323") >= 0.19 _
Or Range("E423") >= -0.21 And Range("F423") >= 0.21 _
Or Range("E474") >= -0.16 And Range("F474") >= 0.16 Then
'MsgBox "Wert " & minWert & " oder " & maxWert & " zu Hoch"
Sheets("Liste").Range("G86").ClearContents
Else
Exit Sub
End If
'wechselt zur Tabelle "Liste" WICHTIG DIESES MUß ALS LETZTES HIN!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Sheets("Liste").Select
Range("J28").Select
Application.ScreenUpdating = True 'Bildschirm Aktualisierung einschalten
End Sub
Da dieser aber sehr umfangreich ist und ich das ganze 79 mal brauch wollte ich mal fragen wie man dieses kürzer schreiben könnte. Wäre für Eure Hilfe sehr dankbar.
Gruß Rene