von newcomer » Di, 10.08.2004 09:03
Hallo Leute,
ich muss euch sagen ich hasse mittlerweile Makros bzw. solche die ich in ein OO freundliches Format bringen muss. Ich habe die Hoffung, dass mir vielleicht jemand bei meinen beiden Makros unter die Arme greift und sich diesem Problem annimmt.
Makro 1:
Sub Zeitberechnung()
'
' Zeitberechnung Makro
' Makro am 20.06.2001 aufgezeichnet
' Entnimmt der Tabelle 2 Werte und Datumsangaben,
' und trägt diese in Tabelle 1 ein
' Wichtig: in Tabelle 2 dürfen nach der Überschrift
' keine Leerzeilen sein
' Kapazität 100 Projekte
Dim SpalteDatenbeginn, ZeileDatenbeginn As Integer
Dim Vorzeichen(1000) As Integer
Dim ProjektTage(1000), Jahrestag(1000), Teilejahreswert(367) As Integer
' In Blatt Zeit-Teile
SpalteOffset = 2
ZeileOffset = 2
' In Blatt Projekt-Teile
SpalteDatenbeginn = 5
ZeileDatenbeginn = 3
'Bereicheivariable auf aktuellen gesamten Zellenbereich setzen
Worksheets("Projekte-Teile").Select
Range("E4").Select
Set Arbeitsbereich = ActiveCell.CurrentRegion
'Bereich unterhalb der Titelzeilen festlegen
Set TeileBereich = Range(Arbeitsbereich.Cells(ZeileDatenbeginn, SpalteDatenbeginn), _
Arbeitsbereich.Cells(Arbeitsbereich.Rows.Count, _
Arbeitsbereich.Columns.Count))
'Laufzeit des jeweiligen Projekts in Tagen berechnen
' In Projekttage wird Dauer des Projekts
' In Jahrestag der Tag des Jahres 1.1.=1 und 31.12=365
zähler = 1
For n = ZeileDatenbeginn To Arbeitsbereich.Rows.Count
ProjektTage(zähler) = DateDiff("d", Cells(n, 1), Cells(n, 2))
Jahrestag(zähler) = DateDiff("d", DateValue(Cells(3, 1)), Cells(n, 1)) + 1
If Cells(n, 4) > 0 Then
Vorzeichen(zähler) = 1
Else
Vorzeichen(zähler) = -1
End If
zähler = zähler + 1
Next
For Teilnr = 1 To TeileBereich.Columns.Count
'N-te Spalte Durchlaufen
' Teilejahreswert initialisieren
For zähler = 1 To 367
Teilejahreswert(zähler) = 0
Next
zähler = 1
'Durchlaufen einer "Teile-Spalte" und berechnen der Jahreswerte in Teilejahreswert
' Teilejahreswert eigentlich von 1 bis 365 wegen Schaltjahr und Index 0 367 Werte
For Each Zelle In TeileBereich.Columns(Teilnr).Rows
'Wert des Zähler-ten Projekts wird in Teilejahreswert eingetragen
For i = Jahrestag(zähler) To (Jahrestag(zähler) + ProjektTage(zähler))
Teilejahreswert(i) = Teilejahreswert(i) + Zelle.Value * Vorzeichen(zähler)
Next
zähler = zähler + 1
Next
' Berechnete Werte eines Teils für ein Jahr sind jetzt in "Teilejahreswert" gespeichert
' und werden nun ins andere Tabellenblatt kopiert
i = 1
Worksheets("Zeit-Teile").Select
For i = 1 To 365
Cells(i + ZeileOffset, Teilnr + SpalteOffset) = Teilejahreswert(i)
Next
Next
End Sub
Makro 2:
'
' Makro am 28.10.1994 aufgezeichnet
'
'
Sub Auto_Open()
'Anfangs- und Endzeile des ZEROKATALOGS
Kataloganfang = 1
Katalogende = 999
'Erste Zeile vor Pos. 01
Angebotszeile = 7
'Schleife bis alle Elemente eingegeben
Do
Sheets("Tabelle1").Select
Abfrage = False
'Schleife zum Eingeben
Do
DialogSheets("ZERO").Show
Colour = DialogSheets("ZERO").EditBoxes("Bearbeitungsfeld 7").Text
Meinelement = DialogSheets("ZERO").EditBoxes("Bearbeitungsfeld 9").Text
Stückzahl = DialogSheets("ZERO").EditBoxes("Bearbeitungsfeld 11").Text
Meinelement = Meinelement + Colour
m = Kataloganfang
'Prüfen und suchen der Eingabe
Do While m <= Katalogende
If Cells(m, 1).Text = Meinelement Then
Datensatz = m
Abfrage = True
Exit Do
ElseIf Cells(m, 2).Text = Meinelement Then
Datensatz = m
Abfrage = True
Exit Do
ElseIf Meinelement = "" Then
Abfrage = True
Exit Do
End If
m = m + 1
Loop
If m > Katalogende Then
Mldg = "Falsche Zero-Code Nummer eingegeben"
MsgBox (Mldg)
End If
Loop Until Abfrage = True
'Nicht benötigte vorbereitete zwei Zeilen löschen
If Meinelement = "" Then
'Prozente abfragen und einsetzen
Löschrabat = 0
Rabatt = InputBox("Gewährten Rabatt eingeben z.B. 25", "RABATT-STAFFEL")
If Rabatt = "" Then
' Zeilen Rabatt und Netto-Material zusätzlichen löschen
Löschrabat = 6
Else
Sheets("Tabelle2").Select
Cells(Angebotszeile + 8, 3).Activate
Cells(Angebotszeile + 8, 3) = Rabatt / 100
End If
Sheets("Tabelle2").Select
Löschezeil = 2
While Löschezeil > 0
'Zusätzliche Zeilen in die Datensätze kämen löschen
Rows(Angebotszeile + Löschezeil).Select
Selection.Delete
Löschezeil = Löschezeil - 1
Wend
If Löschrabat = 6 Then
ActiveSheet.DrawingObjects("Text 9").Select
Selection.Delete
ActiveSheet.DrawingObjects("Text 10").Select
Selection.Delete
End If
While Löschrabat > 0
'Zusätzliche Zeilen Rabatt und Netto-Material löschen
Rows(Angebotszeile + 4 + Löschrabat).Select
Selection.Delete
Löschrabat = Löschrabat - 1
Wend
Exit Do
End If
'Kopieren aus Katalog in Extraktion
Range(Cells(Datensatz, 2), Cells(Datensatz, 4)).Select
Selection.Copy
'Gefundenen Datensatz in nächstes Tabellenblatt
Sheets("Tabelle2").Select
Angebotszeile = Angebotszeile + 1
' Spalte 1 für Pos. frei lassen
Cells(Angebotszeile, 2).Activate
ActiveSheet.Paste
Cells(Angebotszeile, 5) = Stückzahl
'Vorbereitung zur Aufnahme weiterer Datensätze
Rows(Angebotszeile + 2).Select
Selection.Insert Shift:=xlBottom
Rows(Angebotszeile + 1).Select
Selection.Copy
Cells(Angebotszeile + 2, 1).Activate
ActiveSheet.Paste
Cells(Angebotszeile + 1, 1).Activate
Loop Until Meinelement = ""
'Alle Eingaben und Berechnungen fertig
'Erstellte Tabelle in Datei ZEROTMP.xls kopieren
'ZEROTMP.xls wird von WinWORD eingebettet
Workbooks.Open Filename:="W:\DATEN\PRISMA\ZERO\ZEROTMP.XLS"
SendKeys "{ENTER}", False
Sheets("Tabelle2").Select
ActiveWindow.SelectedSheets.Delete
Windows("ZEROMAK.XLS").Activate
Sheets("Tabelle2").Copy Before:=Workbooks("ZEROTMP.XLS").Sheets(1)
Range("D4").Select
ActiveWorkbook.Save
'Windows("ZEROTMP.XLS").Activate
ActiveWorkbook.Close
Application.DisplayAlerts = False
Application.Quit
End Sub
Ich danke euch schon mal im voraus, wenn ihr euch diesem Problem auseinandersetzt.
Gruß
newcomer
Hallo Leute,
ich muss euch sagen ich hasse mittlerweile Makros bzw. solche die ich in ein OO freundliches Format bringen muss. Ich habe die Hoffung, dass mir vielleicht jemand bei meinen beiden Makros unter die Arme greift und sich diesem Problem annimmt.
[b]Makro 1:[/b]
Sub Zeitberechnung()
'
' Zeitberechnung Makro
' Makro am 20.06.2001 aufgezeichnet
' Entnimmt der Tabelle 2 Werte und Datumsangaben,
' und trägt diese in Tabelle 1 ein
' Wichtig: in Tabelle 2 dürfen nach der Überschrift
' keine Leerzeilen sein
' Kapazität 100 Projekte
Dim SpalteDatenbeginn, ZeileDatenbeginn As Integer
Dim Vorzeichen(1000) As Integer
Dim ProjektTage(1000), Jahrestag(1000), Teilejahreswert(367) As Integer
' In Blatt Zeit-Teile
SpalteOffset = 2
ZeileOffset = 2
' In Blatt Projekt-Teile
SpalteDatenbeginn = 5
ZeileDatenbeginn = 3
'Bereicheivariable auf aktuellen gesamten Zellenbereich setzen
Worksheets("Projekte-Teile").Select
Range("E4").Select
Set Arbeitsbereich = ActiveCell.CurrentRegion
'Bereich unterhalb der Titelzeilen festlegen
Set TeileBereich = Range(Arbeitsbereich.Cells(ZeileDatenbeginn, SpalteDatenbeginn), _
Arbeitsbereich.Cells(Arbeitsbereich.Rows.Count, _
Arbeitsbereich.Columns.Count))
'Laufzeit des jeweiligen Projekts in Tagen berechnen
' In Projekttage wird Dauer des Projekts
' In Jahrestag der Tag des Jahres 1.1.=1 und 31.12=365
zähler = 1
For n = ZeileDatenbeginn To Arbeitsbereich.Rows.Count
ProjektTage(zähler) = DateDiff("d", Cells(n, 1), Cells(n, 2))
Jahrestag(zähler) = DateDiff("d", DateValue(Cells(3, 1)), Cells(n, 1)) + 1
If Cells(n, 4) > 0 Then
Vorzeichen(zähler) = 1
Else
Vorzeichen(zähler) = -1
End If
zähler = zähler + 1
Next
For Teilnr = 1 To TeileBereich.Columns.Count
'N-te Spalte Durchlaufen
' Teilejahreswert initialisieren
For zähler = 1 To 367
Teilejahreswert(zähler) = 0
Next
zähler = 1
'Durchlaufen einer "Teile-Spalte" und berechnen der Jahreswerte in Teilejahreswert
' Teilejahreswert eigentlich von 1 bis 365 wegen Schaltjahr und Index 0 367 Werte
For Each Zelle In TeileBereich.Columns(Teilnr).Rows
'Wert des Zähler-ten Projekts wird in Teilejahreswert eingetragen
For i = Jahrestag(zähler) To (Jahrestag(zähler) + ProjektTage(zähler))
Teilejahreswert(i) = Teilejahreswert(i) + Zelle.Value * Vorzeichen(zähler)
Next
zähler = zähler + 1
Next
' Berechnete Werte eines Teils für ein Jahr sind jetzt in "Teilejahreswert" gespeichert
' und werden nun ins andere Tabellenblatt kopiert
i = 1
Worksheets("Zeit-Teile").Select
For i = 1 To 365
Cells(i + ZeileOffset, Teilnr + SpalteOffset) = Teilejahreswert(i)
Next
Next
End Sub
[b]Makro 2:[/b]
'
' Makro am 28.10.1994 aufgezeichnet
'
'
Sub Auto_Open()
'Anfangs- und Endzeile des ZEROKATALOGS
Kataloganfang = 1
Katalogende = 999
'Erste Zeile vor Pos. 01
Angebotszeile = 7
'Schleife bis alle Elemente eingegeben
Do
Sheets("Tabelle1").Select
Abfrage = False
'Schleife zum Eingeben
Do
DialogSheets("ZERO").Show
Colour = DialogSheets("ZERO").EditBoxes("Bearbeitungsfeld 7").Text
Meinelement = DialogSheets("ZERO").EditBoxes("Bearbeitungsfeld 9").Text
Stückzahl = DialogSheets("ZERO").EditBoxes("Bearbeitungsfeld 11").Text
Meinelement = Meinelement + Colour
m = Kataloganfang
'Prüfen und suchen der Eingabe
Do While m <= Katalogende
If Cells(m, 1).Text = Meinelement Then
Datensatz = m
Abfrage = True
Exit Do
ElseIf Cells(m, 2).Text = Meinelement Then
Datensatz = m
Abfrage = True
Exit Do
ElseIf Meinelement = "" Then
Abfrage = True
Exit Do
End If
m = m + 1
Loop
If m > Katalogende Then
Mldg = "Falsche Zero-Code Nummer eingegeben"
MsgBox (Mldg)
End If
Loop Until Abfrage = True
'Nicht benötigte vorbereitete zwei Zeilen löschen
If Meinelement = "" Then
'Prozente abfragen und einsetzen
Löschrabat = 0
Rabatt = InputBox("Gewährten Rabatt eingeben z.B. 25", "RABATT-STAFFEL")
If Rabatt = "" Then
' Zeilen Rabatt und Netto-Material zusätzlichen löschen
Löschrabat = 6
Else
Sheets("Tabelle2").Select
Cells(Angebotszeile + 8, 3).Activate
Cells(Angebotszeile + 8, 3) = Rabatt / 100
End If
Sheets("Tabelle2").Select
Löschezeil = 2
While Löschezeil > 0
'Zusätzliche Zeilen in die Datensätze kämen löschen
Rows(Angebotszeile + Löschezeil).Select
Selection.Delete
Löschezeil = Löschezeil - 1
Wend
If Löschrabat = 6 Then
ActiveSheet.DrawingObjects("Text 9").Select
Selection.Delete
ActiveSheet.DrawingObjects("Text 10").Select
Selection.Delete
End If
While Löschrabat > 0
'Zusätzliche Zeilen Rabatt und Netto-Material löschen
Rows(Angebotszeile + 4 + Löschrabat).Select
Selection.Delete
Löschrabat = Löschrabat - 1
Wend
Exit Do
End If
'Kopieren aus Katalog in Extraktion
Range(Cells(Datensatz, 2), Cells(Datensatz, 4)).Select
Selection.Copy
'Gefundenen Datensatz in nächstes Tabellenblatt
Sheets("Tabelle2").Select
Angebotszeile = Angebotszeile + 1
' Spalte 1 für Pos. frei lassen
Cells(Angebotszeile, 2).Activate
ActiveSheet.Paste
Cells(Angebotszeile, 5) = Stückzahl
'Vorbereitung zur Aufnahme weiterer Datensätze
Rows(Angebotszeile + 2).Select
Selection.Insert Shift:=xlBottom
Rows(Angebotszeile + 1).Select
Selection.Copy
Cells(Angebotszeile + 2, 1).Activate
ActiveSheet.Paste
Cells(Angebotszeile + 1, 1).Activate
Loop Until Meinelement = ""
'Alle Eingaben und Berechnungen fertig
'Erstellte Tabelle in Datei ZEROTMP.xls kopieren
'ZEROTMP.xls wird von WinWORD eingebettet
Workbooks.Open Filename:="W:\DATEN\PRISMA\ZERO\ZEROTMP.XLS"
SendKeys "{ENTER}", False
Sheets("Tabelle2").Select
ActiveWindow.SelectedSheets.Delete
Windows("ZEROMAK.XLS").Activate
Sheets("Tabelle2").Copy Before:=Workbooks("ZEROTMP.XLS").Sheets(1)
Range("D4").Select
ActiveWorkbook.Save
'Windows("ZEROTMP.XLS").Activate
ActiveWorkbook.Close
Application.DisplayAlerts = False
Application.Quit
End Sub
Ich danke euch schon mal im voraus, wenn ihr euch diesem Problem auseinandersetzt.
Gruß
newcomer