Clever-Excel-Forum

Clever-Excel-Forum > Office-Anwendungen > Excel > Makro verursacht Endlosberechnung, Arbeitsmappe hängt sich auf
Normale Version: Makro verursacht Endlosberechnung, Arbeitsmappe hängt sich auf
Du siehst gerade eine vereinfachte Darstellung unserer Inhalte. Normale Ansicht mit richtiger Formatierung.
Seiten: 1 2 3

snb

15.03.2019, 12:57
Code:
Private Sub Worksheet_Change(ByVal target As Range)
    Application.EnableEvents = False
    
    If Not Intersect(target, Range("H13:H19")) Is Nothing Then
        y = Application.Count(Range("H13:H19"))
        If y = 0 Then y = Application.Count(Range("H13:H14"))
        With Sheets("start")
            .Shapes("Hakenteiln").Visible = y = 2
            .Shapes("HakenTeilnrot").Visible = y = 0
            .Shapes("HakenTeilnorange").Visible = y = 2
        End With
    End If
    
    If Not Intersect(target, Range("C14:C16")) Is Nothing Then
        With Sheets("Start").Shapes("HakenDaten")
            .Visible = Application.Count(Range("C14:C20"))
            Sheets("Start").Shapes("HakenDatenrot").Visible = Not .Visible
        End With
    End If

    If target.Address = "$T$3" Then Haken4

    Application.EnableEvents = True
End Sub



NB. Zuviel Aufwand macht debuggen zu kompliziert.

snb

15.03.2019, 16:30
Verbessert:


Code:
Private Sub Worksheet_Change(ByVal target As Range)
    Application.EnableEvents = False
    
    If Not Intersect(target, Range("H13:H19")) Is Nothing Then
        y = Application.CountA(Range("H13:H19"))
        If y = 0 Then y = Application.CountA(Range("H13:H14"))
        With Sheets("start")
            .Shapes("Hakenteiln").Visible = y > 2
            .Shapes("HakenTeilnrot").Visible = y < 2
            .Shapes("HakenTeilnorange").Visible = y = 2
        End With
    End If
    
    If Not Intersect(target, Range("C14:C16")) Is Nothing Then
        With Sheets("Start").Shapes("HakenDaten")
            .Visible = Application.CountA(Range("C14:C20"))
            Sheets("Start").Shapes("HakenDatenrot").Visible = Not .Visible
        End With
    End If

    If target.Address = "$T$3" Then Sheets("Vorl.").Shapes("MaengelExport").Visible = target.value

    Application.EnableEvents = True
End Sub

kliffi01

19.03.2019, 15:12
Hallo liebe Community,

es gibt Neuigkeiten hinsichtlich meines Problems.
Habe einen neuen Ansatz gewählt:
1. keine ControlSources und RowSources in den Bereichen, in denen ich über "Import" einfüge
2. Daten die mit der UserForm einen Bezug haben werden nun erst beim Aufrufen der UserForm von den Zellen in die Form geschrieben und beim "Übernehmen" in die Zellen zurückgeschrieben.

Hier der Importieren-Code für alle die es sich mal ansehen möchten:
Code:
Public Sub Importieren()
Dim MyFile As Variant
Dim pfad As String, datei As String, blatt As String, bereich As Range, zelle As Object

Call AllesAus

MyFile = Application.GetOpenFilename("Excel mit Makros (*.xlsm), *.xlsm")
If Not MyFile = False Then Else Exit Sub
   
datei = Right(MyFile, Len(MyFile) - InStrRev(MyFile, "\"))
pfad = Left(MyFile, InStrRev(MyFile, "\") - 1)
blatt = "Start"

Set bereich = Range("L3:S10")
   For Each zelle In bereich
       zelle = zelle.Address(False, False)
       ActiveSheet.Cells(zelle.Row, zelle.Column).Value = GetValue(pfad, datei, blatt, zelle)
       If zelle = "0" Then ActiveSheet.Cells(zelle.Row, zelle.Column).Value = ""
   Next zelle

Set bereich = Range("L25:L32")
   For Each zelle In bereich
       zelle = zelle.Address(False, False)
       ActiveSheet.Cells(zelle.Row, zelle.Column).Value = GetValue(pfad, datei, blatt, zelle)
       If zelle = "0" Then ActiveSheet.Cells(zelle.Row, zelle.Column).Value = ""
   Next zelle
   
Set bereich = Range("K16")
   For Each zelle In bereich
       zelle = zelle.Address(False, False)
       ActiveSheet.Cells(zelle.Row, zelle.Column).Value = GetValue(pfad, datei, blatt, zelle)
       If zelle = "0" Then ActiveSheet.Cells(zelle.Row, zelle.Column).Value = ""
   Next zelle
   
       If Not MyFile = False Then Workbooks.Open (MyFile) Else Exit Sub
       ActiveWorkbook.Sheets("Start").Range("A100:Q1000").Copy
       ThisWorkbook.Worksheets("Start").Range("A100").PasteSpecial xlPasteValues
       Application.DisplayAlerts = False
       ActiveWorkbook.Close SaveChanges:=False
   
Call AllesEin
MsgBox "Importieren der Daten" & vbLf & vbLf & "Benutzer mit Kontaktdaten, Adressen und LuBP" & vbLf & vbLf & "ist abgeschlossen."
ThisWorkbook.Sheets("Start").Range("C14").Select
End Sub

An dieser Stelle vielen Dank an alle die Zeit für einen Rat hatten. 
Besonderen Dank an SNB, das Worksheet_Change Ereignis habe ich nun nach deinem Vorschlag angepasst.

Grüße
Martin
Seiten: 1 2 3
Clever-Excel-Forum > Office-Anwendungen > Excel > Makro verursacht Endlosberechnung, Arbeitsmappe hängt sich auf