Private Sub während Makro blockieren

Hallo zusammen,

ich habe ein Problem, wo ich momentan nicht auf die Lösung komme.

In dem Makro sind unterschiedliche Module, welche Daten aus unterschiedlichen Tabellen nach spezifischen Suchanfragen zusammen führen. Über ein SelectionChange sind zusätzlich "Start" und "Stop" Buttons verknüpft. Leider durchlaufen die Module nach jedem Kopiervorgang das Private Sub Worksheet_SelectionChange, auch wenn dort nichts ausgeführt wird, kostet das ständige Durchlaufen dieses Sub viel Zeit. Ich würde dies gerne verhindern. Application.EnableEvents = False scheint nicht das Problem zu lösen. Hat jemand noch eine Idee???

Hier der Code für das Private Sub Worksheet_SelectionChange

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim wblookup As Workbook
Dim Literaturdatei As String
Dim Suchbegriff As String
Dim Pfad As String
Dim wdApp As Object
Dim wdDoc1 As Object

Set wblookup = ActiveWorkbook

If Selection.Count = 1 Then
    If Not Intersect(Target, Range("I2")) Is Nothing Then
        If ActiveSheet.CheckBoxes("Kontrollkästchen 17").Value = 1 Then
            HRMS1
            Else
        End If
        If ActiveSheet.CheckBoxes("Kontrollkästchen 8").Value = 1 Then
            GCMS1
            Else
        End If
        If ActiveSheet.CheckBoxes("Kontrollkästchen 11").Value = 1 Then
            HPLC1
            Else
        End If
        If ActiveSheet.CheckBoxes("Kontrollkästchen 12").Value = 1 Then
            UPLC1
            Else
        End If
        If ActiveSheet.CheckBoxes("Kontrollkästchen 9").Value = 1 Then
            KFT1
            Else
        End If
        If ActiveSheet.CheckBoxes("Kontrollkästchen 10").Value = 1 Then
            TGA1
            Else
        End If
        If ActiveSheet.CheckBoxes("Kontrollkästchen 13").Value = 1 Then
            Referenz1
            Else
        End If
        If ActiveSheet.CheckBoxes("Kontrollkästchen 14").Value = 1 Then
            Stabi1
            Else
        End If
        If ActiveSheet.CheckBoxes("Kontrollkästchen 15").Value = 1 Then
            LitData1
            Else
        End If
    End If
End If

If Selection.Count = 1 Then
    If Not Intersect(Target, Range("J2")) Is Nothing Then
        Rows("21:65536").Select
        Selection.ClearContents
        Selection.Interior.Color = xlNone
        Selection.Borders.LineStyle = -4142
        Selection.ClearFormats
    End If
End If

If Selection.Count = 1 Then
    If Not Intersect(Target, Range("L2")) Is Nothing Then
        Pfad = "T:\Produktion\Literaturdaten\"
        Suchbegriff = Range("B3").Value
        Literaturdatei = Dir(Pfad & Suchbegriff & "*.doc")
        If Literaturdatei > "" Then
            Set wdApp = VBA.CreateObject("Word.Application")
            wdApp.Visible = True
            wdApp.Activate
            Set wdDoc1 = wdApp.Documents.Open(Pfad & Literaturdatei)
        End If
        Literaturdatei = ""
        Pfad = ""
        Suchbegriff = ""
    End If
End If

End Sub

Hier ein Modul:

Sub HRMS1()
Dim wbHRMS As Workbook
Dim wblookup As Workbook
Dim ws As Worksheet
Dim ItemCode, LIMSNummer, Spezial, Root As String
Dim Anzahl, AnzahlItemCode, AnzahlLIMSNummer, AnzahlProNummer, AnzahlSpezial, AnzahlRoot As Variant
Dim A, b, x, y, LetzteZeile As Long
Dim SZelle As Range

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.CutCopyMode = False
Application.EnableEvents = False

spfad1 = "T:\Ag\oeffentlich\für Peter\ANA_LookUp\Test_PSUP_ANA2.xlsm"
spfad2 = "T:\Ag\oeffentlich\für Peter\ANA_LookUp\HRMS excat mass_PW.xlsx"

Set wblookup = Workbooks.Open(spfad1)
Set wbHRMS = Workbooks.Open(spfad2)

For Each ws In wbHRMS.Worksheets
    If ws.FilterMode = True Then
        ws.ShowAllData
    End If
Next ws

Root = wblookup.Worksheets("Tabelle1").Range("B3")
ItemCode = wblookup.Worksheets("Tabelle1").Range("C3")
LIMSNummer = wblookup.Worksheets("Tabelle1").Range("D3")
Spezial = wblookup.Worksheets("Tabelle1").Range("E3")
LetzteZeile = wblookup.Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row

If ItemCode = "" And LIMSNummer = "" And ProNummer = "" And Spezial = "" And Root = "" Then
    Else
        If ItemCode = Leer Then
            ItemCode = "AZ"
        End If
        If LIMSNummer = Leer Then
            LIMSNummer = "AZ"
        End If
        If Spezial = Leer Then
            Spezial = "AZ"
        End If
        If Root = Leer Then
            Root = "AZ"
        End If
    AnzahlItemCode = Application.WorksheetFunction.CountIf(wbHRMS.Worksheets("Tabelle1").Range("C:C"), ItemCode & "*")
    AnzahlLIMSNummer = Application.WorksheetFunction.CountIf(wbHRMS.Worksheets("Tabelle1").Range("A:A"), LIMSNummer)
    AnzahlProNummer = Application.WorksheetFunction.CountIf(wbHRMS.Worksheets("Tabelle1").Range("B:B"), ItemCode & "*")
    AnzahlSpezial = Application.WorksheetFunction.CountIf(wbHRMS.Worksheets("Tabelle1").Range("D:D"), Spezial)
    AnzahlRoot = Application.WorksheetFunction.CountIf(wbHRMS.Worksheets("Tabelle1").Range("Z:Z"), Root & "*")
    If AnzahlItemCode = 0 And AnzahlLIMSNummer = 0 And AnzahlProNummer = 0 And AnzahlSpezial = 0 And AnzahlRoot = 0 Then
        Else
        LetzteZeile = wblookup.Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
        x = LetzteZeile
        wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + 1, 1) = "HRMS aus Tabelle1"
        With wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + 1, 1).Font
            .Name = "Calibri"
            .Size = 11
            .Italic = False
            .Bold = True
        End With
        wblookup.Worksheets("Tabelle1").Range(wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + 2, 1), wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + 2, 32)) = _
        wbHRMS.Worksheets("Tabelle1").Range("A4:AG4").Value
        With wblookup.Worksheets("Tabelle1").Range(wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + 2, 1), wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + 2, 32)).Font
            .Name = "Calibri"
            .Size = 11
            .Italic = True
            .Bold = False
        End With
        With wblookup.Worksheets("Tabelle1").Range(wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + 2, 1), wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + 2, 33)).Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThick
        End With
        wbHRMS.Worksheets("Tabelle1").Range("Z:Z").Copy
        wbHRMS.Worksheets("Tabelle1").Range("Z:Z").PasteSpecial Paste:=xlValues
        b = wblookup.Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
        If AnzahlRoot = 0 Or Root = "" Then
            Else
            LetzteZeile = wblookup.Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
            For A = 1 To AnzahlRoot
                If A = 1 Then
                     Set SZelle = wbHRMS.Worksheets("Tabelle1").Range("Z:Z").Find(Root & "*")
                     wbHRMS.Worksheets("Tabelle1").Range(wbHRMS.Worksheets("Tabelle1").Cells(SZelle.Row, 1), wbHRMS.Worksheets("Tabelle1").Cells(SZelle.Row, 41)).Copy
                     wblookup.Worksheets("Tabelle1").Range(wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + A, 1), wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + A, 41)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                     Else
                     Set SZelle = wbHRMS.Worksheets("Tabelle1").Range("Z:Z").FindNext(SZelle)
                     wbHRMS.Worksheets("Tabelle1").Range(wbHRMS.Worksheets("Tabelle1").Cells(SZelle.Row, 1), wbHRMS.Worksheets("Tabelle1").Cells(SZelle.Row, 41)).Copy
                     wblookup.Worksheets("Tabelle1").Range(wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + A, 1), wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + A, 41)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                End If
            Next A
        End If
        If AnzahlItemCode = 0 Or ItemCode = "" Then
            Else
            LetzteZeile = wblookup.Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
            For A = 1 To AnzahlItemCode
                If A = 1 Then
                     Set SZelle = wbHRMS.Worksheets("Tabelle1").Range("C:C").Find(ItemCode & "*")
                     wbHRMS.Worksheets("Tabelle1").Range(wbHRMS.Worksheets("Tabelle1").Cells(SZelle.Row, 1), wbHRMS.Worksheets("Tabelle1").Cells(SZelle.Row, 41)).Copy
                     wblookup.Worksheets("Tabelle1").Range(wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + A, 1), wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + A, 41)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                     Else
                     Set SZelle = wbHRMS.Worksheets("Tabelle1").Range("C:C").FindNext(SZelle)
                     wbHRMS.Worksheets("Tabelle1").Range(wbHRMS.Worksheets("Tabelle1").Cells(SZelle.Row, 1), wbHRMS.Worksheets("Tabelle1").Cells(SZelle.Row, 41)).Copy
                     wblookup.Worksheets("Tabelle1").Range(wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + A, 1), wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + A, 41)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                End If
            Next A
        End If
        If AnzahlLIMSNummer = 0 Or LIMSNummer = "" Then
            Else
            LetzteZeile = wblookup.Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
            For A = 1 To AnzahlLIMSNummer
                If A = 1 Then
                     Set SZelle = wbHRMS.Worksheets("Tabelle1").Range("A:A").Find(LIMSNummer & "*")
                     wbHRMS.Worksheets("Tabelle1").Range(wbHRMS.Worksheets("Tabelle1").Cells(SZelle.Row, 1), wbHRMS.Worksheets("Tabelle1").Cells(SZelle.Row, 41)).Copy
                     wblookup.Worksheets("Tabelle1").Range(wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + A, 1), wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + A, 41)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                     Else
                     Set SZelle = wbHRMS.Worksheets("Tabelle1").Range("A:A").FindNext(SZelle)
                     wbHRMS.Worksheets("Tabelle1").Range(wbHRMS.Worksheets("Tabelle1").Cells(SZelle.Row, 1), wbHRMS.Worksheets("Tabelle1").Cells(SZelle.Row, 41)).Copy
                     wblookup.Worksheets("Tabelle1").Range(wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + A, 1), wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + A, 41)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                End If
            Next A
        End If
        If AnzahlProNummer = 0 Or ItemCode = "" Then
            Else
            LetzteZeile = wblookup.Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
            For A = 1 To AnzahlProNummer
                If A = 1 Then
                     Set SZelle = wbHRMS.Worksheets("Tabelle1").Range("B:B").Find(ItemCode & "*")
                     wbHRMS.Worksheets("Tabelle1").Range(wbHRMS.Worksheets("Tabelle1").Cells(SZelle.Row, 1), wbHRMS.Worksheets("Tabelle1").Cells(SZelle.Row, 41)).Copy
                     wblookup.Worksheets("Tabelle1").Range(wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + A, 1), wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + A, 41)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                     Else
                     Set SZelle = wbHRMS.Worksheets("Tabelle1").Range("B:B").FindNext(SZelle)
                     wbHRMS.Worksheets("Tabelle1").Range(wbHRMS.Worksheets("Tabelle1").Cells(SZelle.Row, 1), wbHRMS.Worksheets("Tabelle1").Cells(SZelle.Row, 41)).Copy
                     wblookup.Worksheets("Tabelle1").Range(wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + A, 1), wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + A, 41)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                End If
            Next A
        End If
        If AnzahlSpezial = 0 Or Spezial = "" Then
            Else
            LetzteZeile = wblookup.Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
            For A = 1 To AnzahlSpezial
                If A = 1 Then
                     Set SZelle = wbHRMS.Worksheets("Tabelle1").Range("D:D").Find(Spezial & "*")
                     wbHRMS.Worksheets("Tabelle1").Range(wbHRMS.Worksheets("Tabelle1").Cells(SZelle.Row, 1), wbHRMS.Worksheets("Tabelle1").Cells(SZelle.Row, 41)).Copy
                     wblookup.Worksheets("Tabelle1").Range(wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + A, 1), wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + A, 41)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                     Else
                     Set SZelle = wbHRMS.Worksheets("Tabelle1").Range("D:D").FindNext(SZelle)
                     wbHRMS.Worksheets("Tabelle1").Range(wbHRMS.Worksheets("Tabelle1").Cells(SZelle.Row, 1), wbHRMS.Worksheets("Tabelle1").Cells(SZelle.Row, 41)).Copy
                     wblookup.Worksheets("Tabelle1").Range(wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + A, 1), wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + A, 41)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                End If
            Next A
        End If
        wblookup.Worksheets("Tabelle1").Activate
        LetzteZeile = wblookup.Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
        wblookup.Worksheets("Tabelle1").Range(wblookup.Worksheets("Tabelle1").Cells(b, 1), wblookup.Worksheets("Tabelle1").Cells(LetzteZeile, 33)).RemoveDuplicates Columns:=Array(1, 2)
        y = LetzteZeile
        Do
        If Cells(LetzteZeile, 1).Value = "" And Cells(LetzteZeile, 2).Value = "" Then
            Cells(LetzteZeile, 1).EntireRow.Delete
            LetzteZeile = LetzteZeile - 1
            Else
            LetzteZeile = LetzteZeile - 1
            End If
        Loop Until LetzteZeile = b
        With wblookup.Worksheets("Tabelle1").Range(wblookup.Worksheets("Tabelle1").Cells(b + 3, 1), wblookup.Worksheets("Tabelle1").Cells(y, 33)).Font
            .Name = "Calibri"
            .Size = 11
            .Italic = False
            .Bold = False
        End With
    End If
 End If
        
wbHRMS.Close SaveChanges:=False

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.CutCopyMode = True
Application.EnableEvents = True

End Sub

Der SelectionChange wird nach meinem Verständnis duch die copy-Zeile ausgelößt?!

VG Klaus Maus

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hi
Generell sollte das Application.EnabelEvents = False die Ausführung der Automatischen Eventmakros verhindern.
wenn das bei dir nicht funktioniert, könnte es daran liegen, dass du es vielleicht irgenwo unabsichlich wieder auf True gesetzt hast.
sowas kann passieren, wenn sich die Makros gegenseitig aufrufen, da muss man schon aufpassen, wann man was macht.

am besten ist natürlich, so zu programmieren dass die Events nicht oder nur selten ausgelöst werden.
wenn man das macht, kann man die Einzelfälle, die noch übrig bleiben, dann direkt darin einkapseln, dh anstatt am Anfang und Ende des Makros führt man das nur dort aus, wo es benötigt wird:

also statt:

Sub xxx()
Application.EnableEvents = false
...
...
Befehl
...
...
Application.EnabelEvents = True
End Sub

dann

Sub xxx()
...
...
Application.EnableEvents = false
Befehl
Application.EnableEvents = true
...
...
End Sub

aber wie gesagt, besser ist eigentlich vermeiden.
für die Befehle, die implizit eine Selektion ausführen, muss man sich dann einen Workaround ausdenken.
Beispielsweise kann man

Range(xxx).Copy
Range(xxx).PasteSpecial xlpastevalues

durch

Range(xxx).value = Range(xxx).value

ersetzen, hierbei wird keine Selektion ausgeführt.
Man muss nur die beiden Zellbereiche volltständig angeben, beim PasteSpecial reicht ja linke obere Zelle.

Gruß Daniel

Application.EnableEvents = False wbHRMS.Worksheets("Tabelle1").Range(wbHRMS.Worksheets("Tabelle1").Cells(SZelle.Row, 1), wbHRMS.Worksheets("Tabelle1").Cells(SZelle.Row, 41)).Copy wblookup.Worksheets("Tabelle1").Range(wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + A, 1), wblookup.Worksheets("Tabelle1").Cells(LetzteZeile + A, 41)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats Application.EnableEvents = True

If Selection.Count = 1 Then If Not Intersect(Target, Range("J2")) Is Nothing Then Rows("21:65536").Select Selection.ClearContents Selection.Interior.Color = xlNone Selection.Borders.LineStyle = -4142 Selection.ClearFormats End If End If

If Selection.Count = 1 Then If Not Intersect(Target, Range("J2")) Is Nothing Then With Rows("21:65536") .ClearContents .Interior.Color = xlNone .Borders.LineStyle = -4142 .ClearFormats End With End If End If

Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim Literaturdatei As String, Suchbegriff As String, Pfad As String Dim wdApp As Object, wdDoc1 As Object Dim Element As Variant, Boxen As Variant If Intersect(Union(Range("I2"), Range("J2"), Range("L2")), Target) Is Nothing Then Exit Sub If Selection.Count > 1 Then Exit Sub If Target.Address = "$I$2" Then Boxen = Array("17:HRMS1", "8:GCMS1", "11:HPLC1", "12:UPLC1", "9:KFT1", "10:TGA1", "13:Referenz1", "14:Stabil", "15:LitData1") For Each Element In Boxen If Me.CheckBoxes("Kontrollkästchen " & Split(Element, ":")(0)).Value = 1 Then Application.Run Split(Element, ":")(1) Next ElseIf Target.Address = "$J$2" Then Rows("21:65536").Clear ElseIf Target.Address = "$L$2" Then Pfad = "T:\Produktion\Literaturdaten\" Suchbegriff = Range("B3").Value Literaturdatei = Dir(Pfad & Suchbegriff & "*.doc") If Literaturdatei > "" Then Set wdApp = VBA.CreateObject("Word.Application") wdApp.Visible = True wdApp.Activate Set wdDoc1 = wdApp.Documents.Open(Pfad & Literaturdatei) End If Literaturdatei = "" Pfad = "" Suchbegriff = "" Set wdDoc1 = Nothing: Set wdApp = Nothing 'ggf.! End If End Sub

Beliebteste Forumthreads (12 Monate)

Private Sub während Makro blockieren

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Private Sub während Makro blockieren

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread