Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
604to608
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
604to608
604to608
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Macro kürzen????

Macro kürzen????
29.04.2005 19:30:10
Rene
Moin zusammen,
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

15
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Kann mir keiner helfen????
29.04.2005 20:42:20
Rene
Hi,
Hat keiner einen Rat oder ist das ganze zu unübersichtlich?
Gruß Rene
AW: Macro kürzen????
29.04.2005 20:54:02
Hans Heinisch
Hallo Rene,
nimms mir nicht übel. Aber als VBA-Anfänger hatte ich als erstes auf der Zunge "löschen" zu sagen. Kann da noch einer durchblicken?
Nichts für ungut
Gruß
HansH
AW: Macro kürzen????
29.04.2005 21:18:43
Rene
Hi Hans,
Danke für deine Antwort. Ich weiß das es ein ganz schönes Durcheinander ist. Ich vesuche es mal mit Worten zu sagen.
Ich möchte über Excel "*.dat" Dateien einlesen die eine ganze Reihe von Zahlen hat dann wollte ich den Min und den Max Wert ermitteln,wenn dann der Wert größer als ein vorgegebener ist soll er mir in einer anderen Tabelle eine Zelle löschen. Da die Zahlen mit Punkt kommen muß er sie mit Komma ersetzen.
Hoffe das es so halbwegs rübergekommen ist was ich möchte.
Gibt es da vielleicht einen anderen Weg?
Gruß Rene

Anzeige
auweia, da halt ich mich raus, o.w.T
29.04.2005 22:55:27
Reinhard
AW: auweia, da halt ich mich raus, o.w.T
29.04.2005 23:38:27
HansH
Moin Reinhard,
nur keine Bange Reinhard. Das ist doch eine echte Herausforderung!
Gruß aus Ostfriesland
HansH
AW: auweia, da halt ich mich raus, o.w.T
29.04.2005 23:46:26
HansH
Oje!!!
das System mit "Frage offen halten" hab ich noch nicht ganz kapiert. Hätte ich vielelicht mit meinem "Beitrag" (Hilfstätigkeitswort(Ersatz für "tun")) müssen. deshalb sicherheitshalber Beitrag offen.
MfG
HansH
AW: Macro kürzen????
29.04.2005 23:57:31
Hans H
....aber wie? versuch mal so die Frage offen zu halten
HansH
AW: Macro kürzen????
30.04.2005 00:04:06
HansH
;-((((
AW: Macro kürzen????
30.04.2005 09:16:42
Rene
Moin sag ich,
Ich möchte mich erst mal entschuldigen das ich mich gestern nicht mehr gemeldet habe,aber ich war von der Arbeit ordentlich kaputt.Danke an euch das ihr euch das Problem mal angesehen habt.Würde es denn eine Möglichkeit geben so etwas zu vollbringen?
Der Code den ich habe geht zwar aber er ist nun mal zu groß, denn wenn ich das 15 mal schreibe sagt er mir Prozeß zu groß aber ich bräuchte das ganze ja 79 mal. Bitte helft mir.
Gruß Rene
Anzeige
AW: Macro kürzen????
30.04.2005 10:34:34
Rene
Moin,
Versuche mal meine Frage als noch offen zu sagen.
Gruß Rene
AW: Macro kürzen????
30.04.2005 12:56:05
Gert Seler
Hallo Rene,
warum benötigst Du das Modul 79mal?
Du solltest mal eine Beispieltabelle hochladen.

mfg
Gert
AW: Macro kürzen????
30.04.2005 14:09:06
Rene
Hi Gert,
Das Modul brauch ich nicht 79 mal sondern den Code den ich mit dem Recorder aufgezeichnet habe nur das ganze kürzer. Leider kann ich die Tabelle nicht hochladen weil sie zu groß ist.(1,3 MB).
gruß rene
keine 1,3MB, eine Beispieltabelle 20KB o.w.T.
30.04.2005 14:16:49
Reinhard
AW: keine 1,3MB, eine Beispieltabelle 20KB o.w.T.
30.04.2005 14:46:53
Rene
Hi zusammen,
Habe mal die Werte kopiert die ich jedesmal aus einer dat Datei bekomme.
Hier mal die Tabelle:
https://www.herber.de/bbs/user/21925.xls
Spalte B ist der Sollwert und Spalte C ist der Istwert nun darf aber der Istwert nur einen bestimmten Wert über dem Soll sein diesen muß ich aber selber eingeben können da sich dieser für jede Zelle ändert.Als Beispiel C2 zeigt nun den Wert 0,03 an dieses darf aber nicht sein denn der Wert darf höstens nur 0,40 anzeigen wenn C2 alles unter 0,40 anzeigt oder C2 zeigt nun einen Wert von 0,70 an dann soll in dem Sheet "Liste" ein bestimmter Zellinhalt(zB.G7) gelöscht werden. Das ganze würde sich aber nun auf alle 530 Zeilen erfaßt werden.Das alles würde aber eben nur für eine dat Datei sein und ich habe aber 79 dat Dateien und Excel müßte nun alles nacheinander einlesen und auswerten.
Ich hoffe ihr versteht mich wenn nicht Fragen.
Danke erst mal Rene
Anzeige
Ist dieses ausbaufähig?
30.04.2005 15:46:11
Rene
Hi,
Würde diese auch vielleicht gehen:
If Range("C2") > 0.61 Or Range("C2") < 0.11 Then
MsgBox "Zelle muß gelöscht werden"
'Sheets("Liste").Range("G26").ClearContents
Else
MsgBox "Zelle bleibt"
'Exit sub
End If
Hier müßten dabei alle 530 Zeilen(von C2-C530) abgefragt werden was ja ein ganz schöner aufwand wäre würde diese schneller gehen? Denn die Werte wären ja nicht immer gleich.
Gruß Rene

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige