Office: (Office 2013) Laufzeiten-Fehler

Hallo Zusammen,

In einem anderen Thread habe ich eine Anfrage gestellt wo ich nicht weiter komme.

Nun habe ich versucht eine andere Herrangehensweise versucht, allerdings bekomme ich da ein Fehler.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

'** Prüfen, ob der Wert in Zelle H2 geändert wurde
If Not Application.Intersect(Target, Range("H3:H10")) Is Nothing Then
  
  '** Screenupdating und Berechnung deaktivieren
  With Application
    .ScreenUpdating = False
   .Calculation = xlCalculationManual
  End With
  
  '** Dimensinionierung der Variablen
  Dim wsDat
  Dim lngZeile As Long
  Dim lngPos As Long
  
  '** Vorgaben definieren
  Set wsDat = ThisWorkbook.Sheets(1)
  lngZeile = 2 '** Startzeile für Ausgabe in Spalte C
  
  '** Ausgabebereich löschen
  wsDat.Range("C2:C50").ClearContents
  
  '** Spalte H ab Zeile 2 bis zur letzten gefüllten Zeile durchlaufen
  For a = 2 To wsDat.Cells(Rows.Count, 5).End(xlUp).Row
    
    '** Ermittlung der Position, ab der das gesuchte Zeichen aus Zelle C3 gefunden wurde
    lngPos = InStr(1, LCase(wsDat.Cells(a, 5).Value), LCase(wsDat.Range("H3").Value))
    
    '** Daten in Spalte C auflisten, wenn der Suchbegriff vorhanden ist
    If lngPos > 0 Then
      wsDat.Cells(lngZeile, 3).Value = wsDat.Cells(a, 5).Value
      
      '** Zeilenzähler erhöhen
      lngZeile = lngZeile + 1
    End If
    
  Next a

  '**Berechnung und Bildschirmaktualisierung wieder einschalten
  With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
  End With

End If

Diese Zeile macht mir zu schaffen:

Code:

lngPos = InStr(1, LCase(wsDat.Cells(a, 5).Value), LCase(wsDat.Range("H3").Value))

Ändere ich die Range auf H3:H10 bekomme ich ein Laufzeiten-Fehler.

Weiß wer Rat.


Hier habe ich auch ein Thread mit dieser Anfrage gestellt.
https://www.clever-excel-forum.de/Thread-Exel-Formel-und-VBA-Problem?pid=208379#pid208379

 

Hi,

und was genau willst du eigentlich erreichen?

Bis später,
Karin

 

Ich möchte es letztendlich wie auf dem Bild.
In "C2 bis Cxxx" tipt man jeweils immer ein Suchbegriff ein. In "E" ist Artikelliste welche durchsucht wird. In Dropdownliste die gefundenen Suchbegriffe. In "C2 bis Cxxx" wähle ich dann aus wechen Suchbegriff ich haben möchte.

Artikelliste und die Dropdownliste in ein seperates Blatt.


Ps. Bild ist mit Formel nicht mit Makro.

 

Excel ist leider kein Bildbearbeitungsprogramm, sodass du schon eine Beispielmappe und kein Bild hochladen solltest.

Bis später,
Karin

 

oh sorry,

hatte gedacht die wäre im ersten Post.

 

Ich habe noch eine neue Mappe erstellt.

 

Wieso wird jetzt plötzlich die Eingabe nur in C2 überwacht? Weshalb wird der Bereich F2:F50 jedesmal gelöscht wenn in C2 etwas eingegeben wird? Tut mir Leid, aber irgendwie verstehe ich nicht was du machen willst. Beschreibe doch mal in Worten was wie genau ablaufen soll.

Bis später,
Karin

 

Hi Beverly,

Die Funktion sollte wie in Mappe-Test sein. In der Spalte C2 gebe ich den Suchbegriff ein und habe dann die Auswahl im Dropdown.
Problem an der Mappe: Für jedes Dropdown muss ich ein neuen Bereich definieren. Die Mappe würde wenn sie fertig ist ca 160 Dropdowns haben.


Deshalb mein Vorhaben es über Makro zu lösen.
Problem beim Makro: Man muss erst in einer anderen Zelle klicken bevor die Suche ausgefürt wird. Und es fehlt eine Rage "C2:Cxxx"

Die Spalten "E" und "F" sollten wenn es geht in ein seperates Blatt. Optional können die Spalten versteckt werden.


Beispiel: Gibt man in "C2" 4M8 ein, kommen zu Auswahl alle Artikel welche 4M8 enthalten. Für eines muss man sich dann entscheiden.
Gibt man dann in "C3" 929 ein, wird Bereich F2:F50 geslöscht und es kommen zu Auswahl alle Artikel welche 929 enthalten. Wieder muss man sich entscheiden.
Dann C4 usw.

Beste Grüße

 

Hi,

wenn du die in Spalte D gefundenen Daten in Zellen schreibst, dann werden ALLE Gültigkeitslisten angepasst, denn ALLE Zellen erhalten ja denselben Bezug. Und wenn du Spalte F immer wieder löschst, bleibt immer letztendlich immer nur der aus der Liste ausgewählte Eintrag stehen in der Gültigkeitsliste. Es geht also nur, wenn das komplett per VBA mit einem Array gemacht wird und der jeweiligen Gültigkeitsliste zugewiesern werden muss, denn jede Zelle muss eine eigene Gültigkeitsliste erhalten. Versuche es mal so:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngSuche As Range
    Dim strStart As String
    Dim lngZaehler As Long
    Dim arrWerte()
    Dim wsDat
    Dim lngZeile As Long
    Dim lngCal As Long
    '** Prüfen, ob Eingabe im Bereich der Gültigkeitszellen
    If Not Application.Intersect(Target, Columns(3).SpecialCells(xlCellTypeAllValidation)) Is Nothing Then
        ' nur 1 Zelle wurde geändert
        If Target.Count = 1 Then
            '** Screenupdating und Berechnung deaktivieren
            With Application
               lngCal = .Calculation
               .ScreenUpdating = False
               .Calculation = xlCalculationManual
            End With
            ' Eingabe ist nicht leer
            If Target <> "" Then
                ' den eingegebenen Begriff gibt es in Spalte E nicht
                If IsError(Application.Match(Target.Value, Columns(5))) Then
                    ' in Spalte F Eingabe suchen, Teilübereinstimmung
                    Set rngSuche = Columns(5).Find(Target, lookat:=xlPart, LookIn:=xlValues)
                    ' Teilübereinstimmung wurde gefunden
                    If Not rngSuche Is Nothing Then
                        ' Startadresse
                        strStart = rngSuche.Address
                        Do
                            ' Array erweitern
                            ReDim Preserve arrWerte(0 To lngZaehler)
                            ' gefundenen Wert ins Array schreiben
                            arrWerte(lngZaehler) = rngSuche.Value
                            lngZaehler = lngZaehler + 1
                            ' nächsten Treffer suchen
                            Set rngSuche = Columns(5).FindNext(rngSuche)
                        Loop While rngSuche.Address <> strStart
                        ' Array-Inhalte als String zusammensetzen
                        strStart = Join(arrWerte(), ",")
                    End If
                Else
                    strStart = Application.Substitute(Target.Validation.Formula1, ";", ",")
                End If
            Else
                strStart = " "
            End If
            ' Gültigkeit erstellen
            Target.Validation.Delete
            With Target.Validation
                .Add xlValidateList, Formula1:=strStart
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = False
                .ShowError = False
            End With
           '**Berechnung und Bildschirmaktualisierung wieder einschalten
            With Application
                .ScreenUpdating = True
                .Calculation = lngCal
            End With
        End If
    End If
End Sub

Beachte, dass die Eingabe nur in 1 Zelle erfolgen darf - wurden mehrere gleichzeitig ausgewählt und die Eingabe mit Strg+Enter abgeschlossen, passiert gar nichts. Gültigkeitsprüfungen sind ja auch nicht dazu gedacht, gleichzeitig mehrere Zellen auszuwählen.


Bis später,
Karin

 

Super und Danke für deine Hilfe !!!

ich habe es in der Mappe "Mape-Test-2" eingefügt.
Leider bekomme ich einen Fehler. Laufzeitfehler"50290" Anwendungs- oder objektdefinierter Fehler

Beim debuggen zeigt er mir diese Zeile an.

Code:

If Not Application.Intersect(Target, Columns(3).SpecialCells(xlCellTypeAllValidation)) Is Nothing Then

Vielleicht mache ich was falsch.

Beste Grüße


Edit: Ich hatte noch etwas in Spalte "F2" drinne zu stehen gehabt. Nach dem löschen ging es auf anhieb!

Nach ein paar Test kommt Fehler:
-bei einem Zeichen
-bei Zeichen die er nicht findet
-bei 8X oder 8x0

Laufzeitfehler"1004" Anwendungs- oder objektdefinierter Fehler

Code:

.Add xlValidateList, Formula1:=strStart

 

Da musst du schon mal deine Mappe mit dem Code hochladen, denn ich kann das so nicht nachvollziehen.

Bis später,
Karin

 

Ok, wird sofort gemacht.

 

Ändere diese Zeile:

Code:

If IsError(Application.Match(Target.Value, Columns(5)[COLOR=#ff0000][B], 0[/B][/COLOR])) Then

Der rot markierte Teil war irgendwie abhanden gekommen.

Den definierten Namen "bereich" solltest du problemlos löschen können.

Bis später,
Karin

 

Hi,
2 der 3 Fehler sind weg.

-bei einem Zeichen--> funktioniert
-bei Zeichen die er nicht findet--> kommt Fehler wie zuvor. Was mir aufgefallen ist, wenn Fehler kommt wird das Dopdown gelösch. Es ist dann eine "normale" Zelle.
-bei 8X oder 8x0-->funktioniert


Super schnelle Antworten von dir!

 

Ergänze die rot markierten Zeilen:

Code:

            ' Eingabe ist nicht leer
            If Target <> "" Then
                ' den eingegebenen Begriff gibt es in Spalte E nicht
                If IsError(Application.Match(Target.Value, Columns(5), 0)) Then
                    ' in Spalte F Eingabe suchen, Teilübereinstimmung
                    Set rngSuche = Columns(5).Find(Target, lookat:=xlPart, LookIn:=xlValues)
                    ' Teilübereinstimmung wurde gefunden
                    If Not rngSuche Is Nothing Then
                        ' Startadresse
                        strStart = rngSuche.Address
                        Do
                            ' Array erweitern
                            ReDim Preserve arrWerte(0 To lngZaehler)
                            ' gefundenen Wert ins Array schreiben
                            arrWerte(lngZaehler) = rngSuche.Value
                            lngZaehler = lngZaehler + 1
                            ' nächsten Treffer suchen
                            Set rngSuche = Columns(5).FindNext(rngSuche)
                        Loop While rngSuche.Address <> strStart
                        ' Array-Inhalte als String zusammensetzen
                        strStart = Join(arrWerte(), ",")
[COLOR=#ff0000][B]                    Else
                        MsgBox "Keine Übereinstimmung gefunden"
                        strStart = " "[/B][/COLOR]
                    End If
                Else
                    strStart = Application.Substitute(Target.Validation.Formula1, ";", ",")
                End If
            Else
                strStart = " "
            End If

Bis später,
Karin