Hilfe bei "Gesamtprojekt"

[Warkings]

@Warkings  als ich den Code für Eingabe auf eine einzige Zeile änderte prüfte ich mit einer MsgBox ob er mehrfach aufgerufen wird.  Wird er nicht!
    deine Idee EventsEnable einzubauen mag fachlich koirrekt sein, dann werden aber alle 419 Zeilen mi Hidden bearbeitet. Das kostet unnnbötig Zeit.

Da hast Du sicher Recht. Ich habe den bestehenden Code auch ja nicht geändert und nur den Hinweis gegeben, wie man zumindest das unnötige mehrfache Triggern des Change-Event verhindern kann. Nicht mehr und nicht weniger.

[ralf_b]

Code:

Sub listvalidation()

Dim wb As Workbook
Dim ws As Worksheet, wsresult As Worksheet
Dim rng As Range, rngZelle As Range
Dim i  As Long

Set wb = ActiveWorkbook
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
With wb
    Set wsresult = .Worksheets.Add(after:=.Worksheets(.Worksheets.Count))
    wsresult.Name = "Übersicht Validation"
    i = 2

        wsresult.Cells(1, 1).Value = "Blattname"
        wsresult.Cells(1, 2).Value = "Zelladresse"
        wsresult.Cells(1, 3).Value = "Formel"

       For Each ws In .Worksheets
           If ws.Name <> wsresult.Name Then
                On Error Resume Next 'Falls Sheet keine Gültigkeiten enthält
                Set rng = ws.Cells.SpecialCells(xlCellTypeAllValidation)
                If Not rng Is Nothing Then
                    For Each rngZelle In rng
                         
                        wsresult.Cells(i, 1).Value = ws.Name
                        wsresult.Cells(i, 2).Value = rngZelle.Address(0, 0)
                        wsresult.Cells(i, 3).Value = Right(rngZelle.Validation.Formula1, Len(rngZelle.Validation.Formula1) - 1)
                       ' ws.Cells(i, 4)
                        i = i + 1
                       
                    Next
                End If
               
            End If
        Next
   End With
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub

Ich habs damit geprüft, aber vorher hatte ich die Datei entzippt und nach entsprechenden Texten durchsucht. Aber auch in Kommentaren sind Linkadressen vorhanden. 

gruß

rb

[Gast 123]

Hallo Ralf

danke für den Code, werde ich ausprobieren.  Ich wusste nicht das auch kommentare verlinkt sein können.  Hast du dafür auch einen Code?
Ich lade mir die ZIP Datei noch mal runter um alles noch mal genau zu testen. Frage: wenn man Zellen löscht werden die Kommentare nicht mit gelöscht??
Ich meine ja, bin mir aber nicht restlos sicher.  Und ich bin auf die Rückmeldung gespannt ....  Würde mich freuen wenn man die beschleunigen kann.

mfg Gast 123

[ralf_b]

Nicht das du mich falsch verstanden hast.  Ich habe die xlsm Datei in name.zip umbenannt und diese dann entpackt. 

Der Code  steht in meiner personal.xlsb deshalb Activeworkbook und nicht Thisworkbook. Nur nur für den Fall das es das Probleme gibt mit der Referenz.

[CBRA]

Ein frohes neues Jahr euch allen!

Erst einmal vielen Dank für eure Tipps. Ich bin diese Woche noch im Urlaub und kann es nicht ausprobieren. Das steht für nächste Woche auf dem Plan. Mal sehen, ob ich mit euren Fachchinesisch was Angaben kann. Es wird sicher Rückfragen geben. 

Trotzdem vielen Dank für die Hilfe

Christian Brand

[Gast 123]

Hallo

die Datei kann beim Öffnen schneller werden wenn man im Blatt NH aus einigen Zellen die externen Bezüge löscht, und sie durch =MESSGERAETE oder =MESSTECHNIK ersetzt!
Der Kollege ralfB hat sie schon mal genannt::  J11, J12, J13, J15, J36, J108  '\\polizei.hessen.de\zda\HEPA\  usw.  und die Zellen J14 , J99, J100  #BEZUG!  (Bezug verloren!)

Ich kam auf die Idee den DropDown Text der Zellen im Blatt NH in eine freie Spalte als Text zu kopieren, kopierte das DropDown aus der Zelle darüber, und kopierte den Original Text zurück.
Dann sind die externen Verknüpfungen weg und das DropDown holt seine Daten aus dem internen Blatt Messgeraete oder Messtechnik.  
Macht man bei der Eingabe nur die letzte zeile sichtbar, statt 429 zeilen, sollte das Programm von der zeit her zufriedenstellend laufen.

mfg Gast 123

[CBRA]

Guten Morgen!

Das mit den Events hat sicherlich seine Wirkung und nach der Eingabe rechnet er sich nicht mehr dauernd einen Wolf. Geschwindigkeit innerhalb der Eingabe ist nun wieder top! Jedoch habe ich den Code-Vorschlag von Warkings genutzt und nun blendet er mir nach einer Eintragung in Spalte A Zeile 4 bis 219 nicht die nächste Zeile ein, wenn ich in A etwas eingebe. Der Code ist in meinen Augen schlüssig, was übersehe ich hier oder ist da ein mir nicht aufgefallener Fehler?

Alle sonstigen Bezüge, die angesprochen wurden laufen ins Leere, da ich die dafür notwendigen Blätter gelöscht habe. Diese waren nicht notwendig und laufen hier im Original einwandfrei.

Wenn wir das ein und ausblenden noch hinbekommen, dann ist mir hier schon ausreichend geholfen.

@Warkings: Ich zweifle nicht daran, dass es deutlich einfach geht und wahrscheinlich auch effizienter, allerdings ist das für einen "Laien" wie mich, der zwar interessiert ist, aber überhaupt nicht von Fach, einfach nicht umsetzbar. Dazu müsste ich wahrscheinlich ein paar Kurse belegen und täglich damit umgehen, das ist aber nicht meine Hauptaufgabe und ich versuche nur mir und meinen Kollegen die Arbeit einfacher zu machen. Deshalb bin ich für jede Unterstützung dankbar, bin mir aber durchaus bewusst, dass wenn es jemand wie Du umsetzen würde, ganz anders aussehen könnte.

Vielen Dank auf alle Fälle bis hierhin und ich würde mich freuen, wenn wir das letzte Stück noch irgendwie hinbekommen und mich hierbei noch jemand unterstützt.

[ralf_b]

versuchs mal damit. Target repräsentiert die aktuell geänderte Zelle/Bereich

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim Zeile As Integer

    On Error GoTo EH
    Application.EnableEvents = False
 
  'Bereichsabgrenzung
  if Target.count >1 then goto eh
  If Target.Column <> 1 Then goto EH
  If Target.Row < 4 OR Target.Row > 219 Then GoTo EH
 
    'Zeilen in Abhängigkeit der Eintragung einblenden
    For Zeile = 219 To 4 Step -1
 
        If Range("A" & Zeile - 1) <> "" Then
            Rows(Zeile).EntireRow.Hidden = False
            Range("A" & Zeile).Select
            Exit For
        Else
            If Zeile > 4 Then
                Rows(Zeile).EntireRow.Hidden = True
            End If
      End If
    Next Zeile
 
EH:
    Application.EnableEvents = True

End Sub

[Gast 123]

Hallo

ist mir eine höfliche Frage erlaubt, oder muss ich an meinem logisch denkendem Verstand zweifeln. Ich denke das kann ich gut!
Bei AutoOpen der Datei werden doch die Zeilen von 2 bis 429 eingeblendet! Das muss man doch nicht jedesmal neu wiederholen.

Was ist bitte mit meinem Makro, das immer nur die nächste Zeile einblendet. und wird der Wert gelöscht wird sie wieder ausgeblendet.
Das geht bei einer einigen Zeile rucki zucki.  Warum der absolut unnötige Aufwand mit For Next Schleife????  Sorry. ist mir zu hoch!
siehe Antwort  #7

mfg Gast 123

[snb]

Brrrrr.

Verzichte auf merged cells.
Verwende intelligente Tabellen, und A1 als erste Zelle in der Tabelle
Integriere alle ähnliche Arbeitsblätter (SH, SDH usw.)

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    If Intersect(Target, Range("M4:M219")) Is Nothing Then Exit Sub
    Cancel = True
   
  With CreateObject("outlook.application").CreateItemFromTemplate("\\polizei.hessen.de\zda\HEPA\FORTBILDUNG\F3\ALLE\##_OfMa\###Stellungnahmen\Signatur OfMa.oft")
      .Subject = "Antrag auf Stellungnahme zu einer ortsfesten Geschwindigkeitsmessanlage vom " & Tabelle1.Cells(Zeile, 3)
      .BODY = "Sehr geehrte Damen und Herren," & vbCrLf & vbCrLf & "Ihr Antrag auf Stellungnahme zu einem Standort einer geplanten oder bestehenden ortsfesten Geschwindigkeitsmessanlage ist bei der Polizeiakademie Hessen eingegangen und wird unter folgendem Aktenzeichen geführt: 66k 12 09 /F3-OFMA-" & Tabelle1.Cells(Zeile, 1) & vbCrLf & vbCrLf & "Für Rückfragen nutzen Sie bitte ausschließlich dieses Aktenzeichen!" & vbCrLf & vbCrLf _
    & "Bezugnehmend auf Ihr Schreiben sende ich Ihnen das Antragsformular als Bewertungsgrundlage für die Bearbeitung Ihres Antrages sowie nachfolgende Informationen zu. Sollten Sie uns die u.a. Informationen bereits alle zugesendet haben, können Sie diese Hinweise als gegenstandslos betrachten." & vbCrLf & vbCrLf _
    & "Gemäß anhängenden Erlass des Hessischen Ministeriums des Innern und für Sport (LPP 1 - 66 k 07 - 15/001) ist die Polizeiakademie Hessen vor Errichtung von Ortsfesten Geschwindigkeitsmessanlagen anzuhören und von dieser eine Stellungnahme zu fertigen." & vbCrLf & vbCrLf _
    & "Zunächst möchte ich sie bitten, mir weiterhin alle Schriftstücke und Anlagen digital zukommen zu lassen. Im Übrigen benötige ich noch einige weitere Informationen, die sie im folgenden Text finden." & vbCrLf & vbCrLf _
    & "Im Verkehrsüberwachungserlass vom 05. Februar 2015 sind in Ziffer 4 die Kriterien genannt, wonach Geschwindigkeitsmessstellen auszuwählen sind. Ich bitte sie daher ihre Standorte diesbezüglich noch einmal zu überprüfen. Sollte ein Kriterium oder mehrere der genannten Kriterien (Ziffer 4.1.1 bis 4.1.5) nach ihrer Meinung erfüllt sein, so bitte ich mir für die jeweiligen Standorte folgende Informationen/Unterlagen zukommen zu lassen:" & vbCrLf & vbCrLf _
    & "a)            Übersichtsplan/-karte mit Markierung der Standorte" & vbCrLf _
    & "b)            Fotos der Standorte" & vbCrLf _
    & "c)            Verkehrszeichenplan der Standorte" & vbCrLf _
    & "d)            Messergebnisse (verdeckter) Geschwindigkeitsmessungen über einen Zeitraum von mindestens 2 Wochen (Verkehrsaufkommen, Überschreitungsquoten, V85, Höchstgeschwindigkeiten)" & vbVerticalTab _
    & "e)            Infos über bereits getroffene Maßnahmen zur Geschwindigkeitsreduzierung." & vbCrLf & vbCrLf _
    & "Unter Verarbeitung sämtlicher Informationen und unter Berücksichtigung der ergänzenden Erläuterungen der örtlich zuständigen Polizei, kommt es zu der bereits genannten Stellungnahme durch die Polizeiakademie Hessen, worin die Installation einer ortsfesten Geschwindigkeitsmessanlage befürwortet oder nicht befürwortet wird." & vbCrLf & vbCrLf _
    & "Für Rückfragen stehe ich gerne zur Verfügung." & vbCrLf

        .to = Target.Offset(, -7)
        .CC = "ofma.f3.hpa@polizei.hessen.de"
      .Attachments.Add ("\\polizei.hessen.de\zda\HEPA\FORTBILDUNG\F3\ALLE\##_OfMa\###Stellungnahmen\2021\_A_Antragsformular_Stellungnahme.docx")
        .Attachments.Add ("\\polizei.hessen.de\zda\HEPA\FORTBILDUNG\F3\ALLE\##_OfMa\###Stellungnahmen\2021\_A_VKÜ-Erlass_StAnz_vom_05.02.2015.pdf")
        .Display
  End With
   
    Application.EnableEvents = False
    Target.Value = "versendet"
    Application.EnableEvents = True
End Sub