Berechnungen per VBA

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
InputBox MsgBox
Bild

Betrifft: Berechnungen per VBA
von: erichm
Geschrieben am: 22.08.2015 07:58:40

Hallo,
mit diesem Beitrag
https://www.herber.de/forum/archiv/1420to1424/t1423165.htm
haben wir zuletzt eine komfortable Lösung erhalten (Ergebnisse ermitteln per VBA statt mit Formel). Auf dieser Basis bzw. Fortsetzung des Tools stehen wir jetzt wieder vor einer ähnlichen Situation, die zwar ggfls. einfacher ist – wegen VBA uns aber wieder überfordert.
Die Datei aus der obigen Lösung habe ich hier hochgeladen, ergänzt um Tabelle Start wegen nachfolgender Frage:
https://www.herber.de/bbs/user/99771.xlsm
Jetzt suchen wir für die „Tabelle Start“ eine VBA-Lösung:
- Bei der wieder das Ergebnis statt die Formel in die Zellen eingetragen wird
- Diese Berechnungen wieder flexibel für Spalten und Zeilen angewendet werden soll – analog der Steuerung wie sie bereits vorhanden ist
Im "ModulStart" haben wir zunächst ein Formel-Makro erstellt.
Besten Dank wiederum für eine Hilfe!
mfg

Bild

Betrifft: AW: Berechnungen per VBA
von: AlexG
Geschrieben am: 22.08.2015 13:32:41
Hallo Erichm,
teste mal

Option Explicit
Sub FormelInZellen1()

Dim wsStart, wsErg As Worksheet
Dim rng As Range
Dim i, j As Long
Set wsStart = Worksheets("Start")
Set wsErg = Worksheets("Ergebnis")
With wsStart
    For i = 3 To .Cells(Rows.Count, 1).End(xlUp).Row
        If wsErg.Cells(i, "C") > 2 Then
            .Cells(i, "C") = "Start"
        Else: .Cells(i, "C") = 1
        End If
        For j = 4 To .Cells(2, Columns.Count).End(xlToLeft).Column
        If wsErg.Cells(i, j).Value + wsErg.Cells(i, j - 1).Value >= 5 Then
            .Cells(i, j).Value = "1Start"
        Else
            If wsErg.Cells(i, j) > 2 Then
                If Right(.Cells(i, j - 1), 2) = "rt" Then
                    .Cells(i, j).Value = "1Start"
                Else: .Cells(i, j).Value = .Cells(i, j - 1).Value + 1 & "Start"
                End If
            Else
                If Right(.Cells(i, j - 1), 2) = "rt" Then
                    .Cells(i, j).Value = 1
                Else: .Cells(i, j).Value = .Cells(i, j - 1).Value + 1
                End If
            End If
        End If
        Next j
    Next i
End With
End Sub
Gruß
Alex

Bild

Betrifft: AW: Berechnungen per VBA
von: erichm
Geschrieben am: 22.08.2015 19:58:44
Hallo Alex,
kurze Zwischeninfo - beim ersten Test hat alles geklappt; melde mich aber morgen nochmals!
Schon mal danke!
mfg

Bild

Betrifft: AW: Berechnungen per VBA
von: erichm
Geschrieben am: 23.08.2015 20:00:07
Hallo Alex,
habe das heute intensiv getestet. Die Ergebnisse stimmen immer!!
Allerdings besteht das Problem, dass ab einem bestimmten Zeilenumfang (ca. größer 1.000 in Tabelle Start) EXCEL dann abstürzt (keine Rückmeldung). Bis 1.000 Zeilen klappt das immer, auch wenn es etwas dauert.
Lösung müsste wohl sein, dass der Codeteil
For i = 3 To .Cells(Rows.Count, 1).End(xlUp).Row
vorher im Zeilenumfang definiert werden müsste; z.B. durch vorgeschaltene InputBoxen bei denen Beginn- und Endzeile eingegeben werden kann. Habe was probiert, bekomme die Endezeile aber nicht hin:

Sub FormelInZellen1()
Dim wsStart, wsErg As Worksheet
Dim rng As Range
Dim i, j As Long
Dim strNameBeginn As String
Dim strNameEnde As String
strNameBeginn = InputBox("Beginnzeile eingeben")
strNameEnde = InputBox("Endezeile eingeben")
Set wsStart = Worksheets("Start")
Set wsErg = Worksheets("Ergebnis")
With wsStart
    For i = strNameBeginn To .Cells(Rows.Count, 1).End(xlUp).Row 'wie wird strNameEnde eingefü _
gt?
        If wsErg.Cells(i, "C") > 2 Then
            .Cells(i, "C") = "Start"
        Else: .Cells(i, "C") = 1
        End If
        For j = 4 To .Cells(2, Columns.Count).End(xlToLeft).Column
        If wsErg.Cells(i, j).Value + wsErg.Cells(i, j - 1).Value >= 5 Then
            .Cells(i, j).Value = "1Start"
        Else
            If wsErg.Cells(i, j) > 2 Then
                If Right(.Cells(i, j - 1), 2) = "rt" Then
                    .Cells(i, j).Value = "1Start"
                Else: .Cells(i, j).Value = .Cells(i, j - 1).Value + 1 & "Start"
                End If
            Else
                If Right(.Cells(i, j - 1), 2) = "rt" Then
                    .Cells(i, j).Value = 1
                Else: .Cells(i, j).Value = .Cells(i, j - 1).Value + 1
                End If
            End If
        End If
        Next j
    Next i
End With
End Sub
Besten Dank für eine nochmalige Hilfe!
mfg

Bild

Betrifft: AW: Berechnungen per VBA
von: Matthias
Geschrieben am: 24.08.2015 14:01:32
Hallo erichm,
Die For-Schleife funktioniert nach folgendem Prinzip:
For i = VON To BIS
VON und BIS sind dabei Zahlen (oder Variablen die Zahlen darstellen). ".Cells(Rows.Count, 1).End(xlUp).Row" zählt bis zur letzten Zeile in Spalte A, der gesamte Ausdruck ergibt also am Ende eine Zahl.
Genauso wie du dein VON ersetzt hast, kannst du auch das BIS ersetzen durch deine Variable.
For i = strNameBeginn To strNameEnde
lg Matthias

Bild

Betrifft: AW: Berechnungen per VBA
von: erichm
Geschrieben am: 24.08.2015 18:39:02
oh, peinlich - hätte nicht gedacht dass das so einfach ist!
VIELEN DANK!
Ich lasse das Thema noch offen wegen der Dauer des Makros; evtl. gibt es da ja noch eine Optimierungsmöglichkeit wie bei der eingangs erwähnten Lösung.
Die ist in der Abarbeitung der Zeilen wesenltich schneller.
Die Hoffnung stirbt zuletzt :)
Danke.
mfg

Bild

Betrifft: AW: Berechnungen per VBA
von: AlexG
Geschrieben am: 26.08.2015 20:36:05
Hallo Erichm,
sorry für die späte Antwort.
Es ist schon mal schön dass die Lösung deinen Wünschen entspricht.
Das Thema mit der For Schleife hat ja Matthias schon erklärt. Danke dafür :-)
Leider kann ich dir bein Thema Speed auch keine Lösung anbieten. Evtl schaltest du die Bildschirm-Aktualisierung ab. Das würde dann so aussehen.

Option Explicit
Sub FormelInZellen1()

Dim wsStart, wsErg As Worksheet
Dim rng As Range
Dim i, j As Long
Set wsStart = Worksheets("Start")
Set wsErg = Worksheets("Ergebnis")
Application.ScreenUpdating = False
With wsStart
    For i = 3 To .Cells(Rows.Count, 1).End(xlUp).Row
        If wsErg.Cells(i, "C") > 2 Then
            .Cells(i, "C") = "Start"
        Else: .Cells(i, "C") = 1
        End If
        For j = 4 To .Cells(2, Columns.Count).End(xlToLeft).Column
        If wsErg.Cells(i, j).Value + wsErg.Cells(i, j - 1).Value >= 5 Then
            .Cells(i, j).Value = "1Start"
        Else
            If wsErg.Cells(i, j) > 2 Then
                If Right(.Cells(i, j - 1), 2) = "rt" Then
                    .Cells(i, j).Value = "1Start"
                Else: .Cells(i, j).Value = .Cells(i, j - 1).Value + 1 & "Start"
                End If
            Else
                If Right(.Cells(i, j - 1), 2) = "rt" Then
                    .Cells(i, j).Value = 1
                Else: .Cells(i, j).Value = .Cells(i, j - 1).Value + 1
                End If
            End If
        End If
        Next j
    Next i
End With
Application.ScreenUpdating = True
End Sub

Gruß
Alex


Bild

Betrifft: AW: Berechnungen per VBA
von: erichm
Geschrieben am: 27.08.2015 07:21:16
Hallo Alex,
danke - das bringt nochmals einen Vorteil.
Jetzt bin ich noch an folgender Optimierung:
Derzeit gebe ich immer über die Inputbox "Beginn- und Endezeile" ein.
Das müsste auch so lösbar sein, dass ich über eine Schleife den Code mehrmals laufen lasse. Wobei dann gilt:
1. Schleife startet immer mit: For i = 3 To 1000
2. Schleife mit: For i = 1001 To 2000
usw....
Das Ende müsste wie folgt fixiert werden:
strNameEnde ist "letzte belegte Zelle in Spalte B", z.B. B8946 (=immer größer als 1.000)
Jetzt müsste die letzte Schleife bei strNameEnde (=8946) beendet werden; d.h. der Codeteil To 2000 oder 3000 usw. müsste erkennen, dass bei 8946 Ende ist.
Meine Code-Versuche stelle ich nicht ein, die sind evtl. eher irreführend.
Ich hoffe meine Beschreibung ist nachvollziehbar.
BESTEN DANK nochmal!
mfg

Bild

Betrifft: als array
von: Michael
Geschrieben am: 27.08.2015 16:53:20
Hi zusammen,
ich habe echt keinen Schimmer, was die Tabelle tun soll.
Optimiert habe ich sie trotzdem mittels Array, und zum direkten Vergleich mit dem Originalcode habe ich je Timer-Abfragen zu Beginn und Ende des Codes:

Option Explicit
Sub FormelInZellen1_optiTest()
Dim aSt As Variant, aEr As Variant
Dim i&, j&, imax&, jmax&
Dim t(0 To 1) As Double
t(0) = Timer
imax = Worksheets("Start").Cells(Rows.Count, 1).End(xlUp).Row
jmax = Worksheets("Start").Cells(2, Columns.Count).End(xlToLeft).Column
aSt = Worksheets("Start").Range("A1", Cells(imax, jmax))
aEr = Worksheets("Ergebnis").Range("A1", Worksheets("Ergebnis").Cells(imax, jmax))
' Application.ScreenUpdating = False
For i = 3 To imax
    If aEr(i, 3) > 2 Then
        aSt(i, 3) = "Start"
    Else: aSt(i, 3) = 1
    End If
    For j = 4 To jmax
    If aEr(i, j) + aEr(i, j - 1) >= 5 Then
        aSt(i, j) = "1Start"
    Else
        If aEr(i, j) > 2 Then
            If Right(aSt(i, j - 1), 2) = "rt" Then
                aSt(i, j) = "1Start"
            Else: aSt(i, j) = aSt(i, j - 1) + 1 & "Start"
            End If
        Else
            If Right(aSt(i, j - 1), 2) = "rt" Then
                aSt(i, j) = 1
            Else: aSt(i, j) = aSt(i, j - 1) + 1
            End If
        End If
    End If
    Next j
Next i
Worksheets("Start").Range("A1", Worksheets("Start").Cells(imax, jmax)) = aSt
' Application.ScreenUpdating = True
t(1) = Timer
MsgBox (t(1) - t(0)) * 1000
End Sub
Sub FormelInZellen1_orig()
Dim wsStart, wsErg As Worksheet
Dim rng As Range
Dim i, j As Long
Dim t(0 To 1) As Double
t(0) = Timer
Set wsStart = Worksheets("Start")
Set wsErg = Worksheets("Ergebnis")
Application.ScreenUpdating = False
With wsStart
    For i = 3 To .Cells(Rows.Count, 1).End(xlUp).Row
        If wsErg.Cells(i, "C") > 2 Then
            .Cells(i, "C") = "Start"
        Else: .Cells(i, "C") = 1
        End If
        For j = 4 To .Cells(2, Columns.Count).End(xlToLeft).Column
        If wsErg.Cells(i, j).Value + wsErg.Cells(i, j - 1).Value >= 5 Then
            .Cells(i, j).Value = "1Start"
        Else
            If wsErg.Cells(i, j) > 2 Then
                If Right(.Cells(i, j - 1), 2) = "rt" Then
                    .Cells(i, j).Value = "1Start"
                Else: .Cells(i, j).Value = .Cells(i, j - 1).Value + 1 & "Start"
                End If
            Else
                If Right(.Cells(i, j - 1), 2) = "rt" Then
                    .Cells(i, j).Value = 1
                Else: .Cells(i, j).Value = .Cells(i, j - 1).Value + 1
                End If
            End If
        End If
        Next j
    Next i
End With
Application.ScreenUpdating = True
t(1) = Timer
MsgBox (t(1) - t(0)) * 1000
End Sub

Der Code läuft in ca. 2/9 vom Original, bringt also 7/9 Einsparung.
Schöne Grüße,
Michael
P.S.: Der optimierte Code läuft mit *auskommentiertem* Screenupdating aus/ein etwa doppelt so schnell wie mit - verstehe ich zwar nicht, ist aber auch nicht schlecht.

Bild

Betrifft: AW: als array
von: erichm
Geschrieben am: 28.08.2015 07:58:39
Hallo Michael,
schon mal besten Dank, das sieht ja sehr gut aus. Eine Grobanalyse passt - melde mich noch nach weiteren Tests!
mfg

Bild

Betrifft: gerne, bis auf weiteres Gruß, M. owT
von: Michael
Geschrieben am: 28.08.2015 12:00:22


Bild

Betrifft: AW: gerne, bis auf weiteres Gruß, M. owT
von: erichm
Geschrieben am: 28.08.2015 20:02:52
Hallo,
also der Code ist wirklich phantastisch und superschnell.
Welche Zeit zeigt denn der Timer an - sind das Millisekunden?
mfg

Bild

Betrifft: freut mich
von: Michael
Geschrieben am: 29.08.2015 15:42:04
Hi,
laut Excel-Hilfe Sekunden seit Mitternacht als Single (habe fälschlicherweise als double geDIMt); die Differenz mal 1000 sind also Millisekunden.
Die Arrays reißen es geschwindigkeitsmäßig einfach raus!
Wenn Du das mal vertiefen möchtest, lies http://www.online-excel.de/excel/singsel_vba.php?f=152
Happy Exceling,
Michael

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Berechnungen per VBA"