Live-Forum - Die aktuellen Beiträge
Datum
Titel
18.05.2024 11:30:18
Summenprodukt mit mehreren Bedungungen (mit Jahr aus Datum)
18.05.2024 10:04:28
Spielzeit von MP4 Dateien auslesen
17.05.2024 20:08:47
Datum/Zeit in einer Zelle fixieren über Makros
17.05.2024 18:14:48
Aaaah! Tabelle erstellen mit Index
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1964to1968
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
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1964to1968
1964to1968
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

VBA Code optimieren

VBA Code optimieren
12.02.2024 09:44:07
Thomas
Hallo zusammen,

der VBA-Code der angehängten Datei überprüft, ob in Spalte H, aufgrund er Daten von Spalte B bis D, ein Terminkonfilikt vorliegt.
Wenn ja, steht in Spalte I der Vermerk "Terminkonflikt" mit den betreffenden Variabeln aus Spalte H, die den Konflikt verursachen.
Der Code funktioniert dann, siehe Zeile 5 und 6, wenn die Variablen am Anfang der Zelle stehen.
Der Code funktioniert nicht, siehe Zeile 7, wenn die betreffende Variable an einer anderen Position steht.

Wäre dankbar dafür, wenn die Code so angepasst werden kann, dass auch nachstehende Variablen geprüft und identifziert werden.

https://www.herber.de/bbs/user/166986.xlsm

Schöne Grüße
Thomas

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA Code optimieren
12.02.2024 10:49:26
Beverly
Hi Thomas,

versuche es mal so: 

Sub TerminKonflikt()

Call Clear_I

    Dim i&, j&, k&, tmpA, tmpB, min#, max#

    Dim tmpNext

    Dim varFehler As Variant

    Dim varNext As Variant

    With Tabelle2

        For i = 2 To .Cells(Rows.Count, 2).End(xlUp).Row - 1

            If .Cells(i, 2) = .Cells(i + 1, 2) Then ' auf gleiches Datum prüfen

                min = .Cells(i, 3)                  ' min max Zeitzahl ermitteln

                If .Cells(i + 1, 3)  min Then min = .Cells(i + 1, 3)

                max = .Cells(i, 4)

                If .Cells(i + 1, 4)  max Then max = .Cells(i + 1, 4)

                ' prüfen auf Zeitfenster zwischen min und max

                If .Cells(i, 3) >= min And .Cells(i + 1, 3) >= min And .Cells(i, 4) = max And .Cells(i + 1, 4) = max Then

                    tmpA = Split(.Cells(i, 8), ", ")

                    tmpB = Split(.Cells(i + 1, 8), ", ")

                    For j = 0 To UBound(tmpA)

                        varFehler = Application.Match(tmpA(j), tmpB, 0)

                        If Not IsError(varFehler) Then   ' prüfen auf doppellten Eintrag(getrennt durch Komma + Leerzeichen)

                            ' Zelle ist noch leer

                            If .Cells(i, 9) = "" Then

                                .Cells(i, 9) = "Terminkonflikt " & tmpA(j)

                            Else

                                ' Inhalt Zielzelle in Array (getrennt durch Leerzeichen)

                                tmpNext = Split(.Cells(i, 9), " ")

                                ' prüfen ob laufender Wert bereits in Ergebniszelle vorhanden

                                varNext = Application.Match(tmpA(j), tmpNext, 0)

                                ' wenn nicht vorhanden dann hinzufügen

                                If IsError(varNext) Then .Cells(i, 9) = .Cells(i, 9) & ", " & tmpA(j)

                            End If

                            If .Cells(i + 1, 9) = "" Then

                                .Cells(i + 1, 9) = "Terminkonflikt " & tmpA(j)

                            Else

                                ' Inhalt Zielzelle in Array (getrennt durch Leerzeichen)

                                tmpNext = Split(.Cells(i + 1, 9), " ")

                                ' prüfen ob laufender Wert bereits in Ergebniszelle vorhanden

                                varNext = Application.Match(tmpA(j), tmpNext, 0)

                                ' wenn nicht vorhanden dann hinzufügen

                                .Cells(i + 1, 9) = .Cells(i + 1, 9) & ", " & tmpA(j)

                            End If

                        End If

                    Next j

                End If

                min = 0

                max = 0

            End If

        Next i

    End With

End Sub


Beachte folgendes: die einzelnen Begriffe in allen Zellen der Spalte H MÜSSEN durch Komma + Leerzeichen getrennt sein und dürfen selbst kein Leerzeichen enthalten.

Noch ein Tipp am Rande - als Code zum Löschen der Spalte H genügt diese eine Zeile 

    Range("I2:I118").ClearContents


Bis später
Karin

Link zur Homepage: https://excel-inn.de/
Anzeige
AW: VBA Code optimieren
12.02.2024 10:54:30
Yal
Hallo Thomas,

um den Code schlank zu halten, muss vorher sortiert werden, sonst sind es zu viele Prüfungen. Nach Sortierung reicht es, die zweite Datum+Uhrzeit gegen dem nächsten erste Datum+Uhrzeit abzugleichen. Ich habe den Check in einer separaten Sub abgelagert. 

Sub TerminKonflikt()

Dim LetzteZeile As Long

Dim i, j

Dim Dat_i, Dat_j

Dim Erg As String



    With Tabelle2

        .Range("I2:I118").ClearContents

        LetzteZeile = .Range("B99999").End(xlUp).Row

        Bereich_Sortieren LetzteZeile 'wichtig, um weniger Bedingungen prüfen zu müssen

        

        For i = 2 To LetzteZeile - 1

            Dat_i = .Cells(i, "B") + .Cells(i, "D") 'vollständige Datum Tag+Uhrzeit erzeugen

            For j = i + 1 To LetzteZeile

                Dat_j = .Cells(j, "B") + .Cells(j, "C")

                If Dat_i >= Dat_j Then

                    Erg = Check(.Cells(i, "H").Value, .Cells(j, "H").Value)

                    If Erg > "" Then

                        Erg = ", " & i & "-" & j & ": " & Erg

                        .Cells(i, "I").Value = .Cells(i, "I").Value & Erg

                        .Cells(j, "I").Value = .Cells(j, "I").Value & Erg

                    End If

                End If

            Next j

        Next i

    'Bereinigung von führenden Kommas

        For i = 2 To LetzteZeile

            If Left(.Cells(i, "I").Value, 1) = "," Then .Cells(i, "I").Value = Trim(Mid(.Cells(i, "I").Value, 2))

        Next i

    End With

End Sub



Private Function Check(Text1 As String, Text2 As String) As String

Dim i, j

Dim Erg As String

    For Each i In Split(Text1, ",")

        i = Trim(i)

        For Each j In Split(Text2, ",")

            If Trim(j) = i Then

                Erg = Erg & ", " & i

            End If

        Next j

    Next i

    Check = Mid(Erg, 3) 'ohne führende ", "

End Function



Private Sub Bereich_Sortieren(LetzteZeile As Long)

    With Tabelle2.Sort

        .SortFields.Clear

        .SortFields.Add2 Key:=Range("B2:B" & LetzteZeile), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

        .SortFields.Add2 Key:=Range("C2:C" & LetzteZeile), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

        .SetRange Range("A2:I" & LetzteZeile)

        .Header = xlGuess

        .MatchCase = False

        .Orientation = xlTopToBottom

        .SortMethod = xlPinYin

        .Apply

    End With

End Sub


VG
Yal
Anzeige
AW: VBA Code optimieren
14.02.2024 11:48:22
Thomas
Super - Dankeschön!

Links zu Excel-Dialogen

Frame

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige