Code Optimierung

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

Betrifft: Code Optimierung
von: Markus
Geschrieben am: 30.07.2015 08:50:06

Hallo zusammen,
ich bin momentan dabei, mein erstes VBA Projekt zu optimieren. Bei vielen Codes wusste ich mir am Anfang nicht besser zu helfen, habe jetzt aber neue Ideen.
So auch hier bei Schritt 1 der Optimierung:
Ich habe eine Combobox, in der die Werte manuell eingetragen sind:

Private Sub UserForm_Initialize()
    KSAuswahlComboBox.Clear
    
    With KSAuswahlComboBox
         .AddItem "3405"
         .AddItem "3406"
         .AddItem "3407"
         .AddItem "3420"
         .AddItem "3421"
         .AddItem "3423"
         .AddItem "3424"
         .AddItem "3425"
         .AddItem "3426"
         .AddItem "3427"
         .AddItem "3428"
         .AddItem "3445"
         .AddItem "7230"
         .AddItem "7231"
         .AddItem "7232"
         .AddItem "7234"
         .AddItem "7235"
         .AddItem "7240"
         .AddItem "7245"
         .AddItem "7247"
         .AddItem "7248"
         .AddItem "7249"
         .ListIndex = 0
    End With
    
End Sub
Ich würde das ganze gerne dynamisch gestalten, indem sich die Liste automatisch mit den Werten ab Zelle "B4" abwärts bis zur ersten leeren Zelle in Spalte "B" befüllt.
Ich würde mich sehr über eure Unterstützung freuen.
Vielen Dank,
Markus

Bild

Betrifft: AW: Code Optimierung
von: Nepumuk
Geschrieben am: 30.07.2015 09:00:16
Hallo,
teste mal:

Private Sub UserForm_Initialize()
    With Worksheets("Tabelle1") 'Anpassen !!!
        KSAuswahlComboBox.List = .Range(.Cells(4, 2), _
            .Cells(.Rows.Count, 2).End(xlUp)).Value
    End With
    KSAuswahlComboBox.ListIndex = 0
End Sub

Gruß
Nepumuk

Bild

Betrifft: Code Optimierung | Schritt 2
von: Markus
Geschrieben am: 30.07.2015 09:42:47
Hallo Nepumuk,
vielen Dank, funktioniert super.
Die Dynamik der Liste hilft mir schonmal für zukünftige Projekte, bei dem aktuellen gibt es jedoch noch einen Zeilenlastigen Stolperstein.
Die Auswahl der KS wird ja durch "Ok" bestätigt und dadurch eine noch statische Funktion aufgerufen:

Private Sub OKCommandButton_Click()
    'Wertet die Auswahl der ComboBox aus
    If KSAuswahlComboBox.Value = 3405 Then
    Unload Me
    Call AuswahlfunktionZeile1
    End If
    'der selbe Code folgt dann für alle weiteren KS, ist aber definiert und dadurch statisch! _

End Sub
Zur Hintergrundinformation:
Die Auswahl der KS dient dazu, aus einem anderen Tabellenblatt die dazu passenden Daten aus einem bestimmten Jahr zu kopieren.
Die Anzahl der Codezeilen hierzu ist leider immens und statisch, sodass ich bei Änderung der KS (neue Nummer, oder komplett neue KS) den ganzen Code entweder anpassen oder kopieren und anpassen muss.
Hier der Code der "AuswahlFunktion1" nur für ein Jahr:
Public Sub AuswahlfunktionZeile1() 'Öffnet Inputbox zur Eingabe der Daten
    Dim s As Variant
    Dim p As String
    Dim rg As Range
    
    s = InputBox("Bitte geben Sie das gewünschte Jahr ein.", "Eingabefeld für: " &    _
Application.UserName)
        
            If s = "" Then 'Falls der Benutzer auf Abbrechen klickt, schließt sich so die  _
Inputbox
            Exit Sub
            End If
            
        If s = 2010 Then
            MsgBox "Aus diesem Jahr sind keine Daten hinterlegt.", vbOKOnly, "Keine Daten"
        End If
        
        If s = 2013 Then
            MsgBox "Aus diesem Jahr sind keine Daten hinterlegt.", vbOKOnly, "Keine Daten"
        End If
        
        If s = 2014 Then
            MsgBox "Aus diesem Jahr sind keine Daten hinterlegt.", vbOKOnly, "Keine Daten"
        End If
        
        'Muss für spätere Jahre angepasst werden
        If s = 2021 Then
            MsgBox "Für dieses Jahr ist die Programmierung noch nicht erfolgt." & Chr(13) & " _
Bitte
         kontaktieren Sie einen Mitarbeiter, der sich mit VBA-Programmierung auskennt.",
         vbOKOnly, "Programmierung fehlt"
        End If
        
'Auswahl, ob B1 oder B2, anschließend werden alle Daten aus der Tabelle "Daten" kopiert und in  _
der Leistungsübersicht eingefügt
        If s = 2011 Then
        p = MsgBox("Stammen Ihre Daten von 2011 aus der Bewertung B1?" & Chr(13) & "Wählen Sie ' _
Nein',
        falls Ihre Daten B2 entstammen", vbYesNo, "Auswahl der Bewertung B1 oder B2")
        
            If p = vbYes Then
             Worksheets("Daten").Range("B5").Copy
             Worksheets("Leistungsübersicht").Range("D4").PasteSpecial xlPasteFormulas ' _
Kopieren der
             Daten aus "Daten" und Zellfärbung
             
                If Worksheets("Leistungsübersicht").Range("D4").Value >= 0.85 Then
                    Worksheets("Leistungsübersicht").Range("D4").Interior.Color = vbGreen
                End If
                If Worksheets("Leistungsübersicht").Range("D4").Value <= 0.85 And _
                 Worksheets("Leistungsübersicht").Range("D4").Value >= 0.75 Then
                    Worksheets("Leistungsübersicht").Range("D4").Interior.Color = vbYellow
                End If
                If Worksheets("Leistungsübersicht").Range("D4").Value <= 0.75 Then
                    Worksheets("Leistungsübersicht").Range("D4").Interior.Color = vbRed
                End If
                
             
             Worksheets("Daten").Range("D5").Copy
             Worksheets("Leistungsübersicht").Range("E4").PasteSpecial xlPasteFormulas
             Worksheets("Daten").Range("F5").Copy
             Worksheets("Leistungsübersicht").Range("F4").PasteSpecial xlPasteFormulas
             Worksheets("Leistungsübersicht").Range("F4").Value = _
             Worksheets("Leistungsübersicht").Range("F4").Value
             Application.CutCopyMode = False
             Set rg = Worksheets("Daten").Range _
             ("C5,H5,I5,N5,O5,T5,U5,Z5,AA5,AF5,AG5,AL5,AM5,AR5,AS5,AX5") 
             'Prüft, ob es noch neuere Werte gibt, AX5 ist notwendig, da sonst im jahr 2020 
             keine leere Zelle mehr vorhanden wäre und VBA einen Fehler meldet. 
             Wird das Jahr 2021 ergänzt, muss dann überall wiederum eine Zelle 
             hinzugefügt werden (z.B.BD5)
             If rg.SpecialCells(xlCellTypeBlanks).Count = rg.Count Then
             Worksheets("Leistungsübersicht").Range("J4").Interior.Color = vbGreen
             Worksheets("Leistungsübersicht").Range("J4").Value = "Ja"
             Else
             Worksheets("Leistungsübersicht").Range("J4").Interior.Color = vbRed
             Worksheets("Leistungsübersicht").Range("J4").Value = "Nein"
             MsgBox "Achtung, für diese Kostenstelle gibt es neuere Daten.", vbOKOnly, "Hinweis" _
             End If
             
             Else 'Falls Nein und damit B2 gewählt wird
             Worksheets("Daten").Range("C5").Copy
             Worksheets("Leistungsübersicht").Range("D4").PasteSpecial xlPasteFormulas
             
                If Worksheets("Leistungsübersicht").Range("D4").Value >= 0.85 Then
                    Worksheets("Leistungsübersicht").Range("D4").Interior.Color = vbGreen
                End If
                If Worksheets("Leistungsübersicht").Range("D4").Value <= 0.85 And _
                Worksheets("Leistungsübersicht").Range("D4").Value >= 0.75 Then
                    Worksheets("Leistungsübersicht").Range("D4").Interior.Color = vbYellow
                End If
                If Worksheets("Leistungsübersicht").Range("D4").Value <= 0.75 Then
                    Worksheets("Leistungsübersicht").Range("D4").Interior.Color = vbRed
                End If
                
             Worksheets("Daten").Range("E5").Copy
             Worksheets("Leistungsübersicht").Range("E4").PasteSpecial xlPasteFormulas
             Worksheets("Daten").Range("G5").Copy
             Worksheets("Leistungsübersicht").Range("F4").PasteSpecial xlPasteFormulas
             Worksheets("Leistungsübersicht").Range("F4").Value = _
             Worksheets("Leistungsübersicht").Range("F4").Value
             Application.CutCopyMode = False
             Set rg = Worksheets("Daten").Range _
             ("H5,I5,N5,O5,T5,U5,Z5,AA5,AF5,AG5,AL5,AM5,AR5,AS5,AX5")
             If rg.SpecialCells(xlCellTypeBlanks).Count = rg.Count Then
             Worksheets("Leistungsübersicht").Range("J4").Interior.Color = vbGreen
             Worksheets("Leistungsübersicht").Range("J4").Value = "Ja"
             Else
             Worksheets("Leistungsübersicht").Range("J4").Interior.Color = vbRed
             Worksheets("Leistungsübersicht").Range("J4").Value = "Nein"
             MsgBox "Achtung, für diese Kostenstelle gibt es neuere Daten.", vbOKOnly, "Hinweis" _
             End If
             
            End If
             
        End If
End Sub

Das ist nur der Code von einem Jahr. Insgesamt gibt es momentan 8 Jahre (2011,2012,2015-2020) und dadurch unglaublich viel Code, denn es gibt ja auch zusätzlich mehrere übergeordnete Kostenstellen, die alle wieder Daten für diese Jahre haben (bzw haben werden).
Mein Wunsch ist es, dass das ganze dynamisch funktioniert und ich nicht mehr tausende an Codezeilen habe.
Vielleicht ist es jetzt zu viel Arbeit, alles nochmal umzuschreiben. Falls dem so ist, sagt mir einfach bescheid :) Wie bereits gesagt wusste ich mir am Anfang nicht besser zu helfen, als alles einzeln und statisch aufzuführen.
Vielen Dank und liebe Grüße,
Markus

Bild

Betrifft: AW: Code Optimierung | Schritt 2
von: Markus
Geschrieben am: 30.07.2015 09:58:18
Ups, vergessen auf "unbewortet" zu schalten :)

Bild

Betrifft: AW: Code Optimierung | Schritt 2
von: Markus
Geschrieben am: 30.07.2015 12:46:13
.

Bild

Betrifft: AW: Code Optimierung | Schritt 2
von: Markus
Geschrieben am: 31.07.2015 07:59:31
-Geschlossen

Bild

Betrifft: AW: Code Optimierung
von: RPP63
Geschrieben am: 30.07.2015 09:02:42
Hallo!
1. Fülle die ComboBox nicht per .AddItem, sondern per .List
2. An .List wird der Bereich übergeben: CB1.List = Range("B4:Bxy")
3. Wie Du die letzte Zeile eines Bereichs ermittelst, müsste klar sein, ist es doch im Ranking der VBA-Fragen wohl auf Platz 1.
Interessante Seite zum Füllen: http://www.snb-vba.eu/VBA_Fill_combobox_listbox_en.html
Gruß Ralf

Bild

Betrifft: Vielen Dank...
von: Markus
Geschrieben am: 30.07.2015 09:59:29
Hallo Ralf
...für deine Hilfe! Klappt jetzt super. Um nicht 2 Threads offen zu lassen, schreibe ich unter dem Beitrag von Nepumuk auf meine Frage weiter.
Danke nochmals und einen schönen Tag.
Gruß
Markus

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Dynamischer Graph"