Makro läuft nach Datenerweiterung nicht mehr

Guten Tag zusammen !
vor einiger Zeit erstellte mir ein Forumane hier die folgende Excel - Datenbank (siehe Anhang)
Die Datenbank ist folgendermassen aufgebaut:
Drei Tabellenblätter: DATENBANK enthält alle Datensätze die Durchsucht werden sollen
AUSWAHL mit diesen Tabellenblatt wird eigentlich gearbeitet um die Datenbank nach besonderen Kriterien zu durchsuchen
CODES Enthält die Cöder und Telefon-Vorwahlen, nach denen gesucht werden soll
Nun soll folgendes gemacht werden können.
Auf dem Registerblatt AUSWAHL setzt der User einen Code in die gelbe Zelle und drückt ENTER
Es sollte nun (entsprechend dem Tabellenblatt CODES) geschrieben werden, um welchen Code es sich hier im Detail handelt.
Wenn man nun auf SUCHEN klickt, so sollen alle Datensätze ab dem Registerblatt DATENBANK, welche diesem Code entsprechend aufgelistet werden. Und zwar nur jene, die auch wirklich einen Namen zur Telefonnummer haben.
Die Telefonnummer wird dann anhand der Vorwahl mit der Telefon-Codes verglichen (Tabellenblatt CODES) um auch die Sprache noch dazu auszugeben.
Dieses Makro / Excel-Datenbank funzte einwandfrei, bis wir noch zusätzliche Codes in die DATENBANK aufgenommen hatten.
Bis und mit dem Code 114 läuft alles noch korrekt,
Was ist nun falsch ?
Muss irgendwo die Matrix oder sonst noch was erweitert werden ?
HERZLICHEN DANK FÜR DIE HILFE !!!!
Und hier noch eine ganz ganz stark abgespeckte und vereinfachte Datenbank als Beispiel
https://www.herber.de/bbs/user/65431.xls

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Sub Code_Auflisten() Dim Bereich As Range, rngFilter As Range With Tabelle1 Set Bereich = Tabelle1.Range(.Columns(1), .Columns(7)) End With With Tabelle2 Set rngFilter = Tabelle2.Range("i3:j4") rngFilter(1, 1) = .Range("A3") rngFilter(1, 2) = .Range("D3") rngFilter(2, 1) = "'" & .Range("B1") rngFilter(2, 2) = "'<>" Bereich.AdvancedFilter xlFilterCopy, rngFilter, .Range("A3:G3") rngFilter.ClearContents End With End Sub

Hallo,
du hast nicht den Code aus der letzten Version übernommen.
Ersetze Deinen Code im Modul durch diesen.

Sub AuswahlOhneDoppelte()
Dim myAr
Dim Dic As Object
Dim A As Long
Dim LRow As Long
Set Dic = CreateObject("Scripting.Dictionary")

With Tabelle1
 With .UsedRange
  .Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlYes
 End With
 myAr = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
End With
    
Dic("<keine Auswahl>") = 0

For A = 1 To Ubound(myAr)
 If myAr(A, 1) <> "" Then
    Dic(myAr(A, 1)) = 0
 End If
Next A

Tabelle3.Range("H2").Resize(Rows.Count - 1).ClearContents
Tabelle3.Range("H2").Resize(Dic.Count) = Application.Transpose(Dic.keys)

With Tabelle2
    .Range("B1").Value = ""
    .Range("A4:H4").Resize(Rows.Count - 4).ClearContents
End With

End Sub
Sub Code_Auflisten()
Dim Bereich As Range, rngFilter As Range
Dim LRow As Long

With Tabelle1
 Set Bereich = Tabelle1.Range(.Columns(1), .Columns(7))
End With

With Tabelle2
    .Range("A4:H4").Resize(Rows.Count - 4).ClearContents
    Set rngFilter = Tabelle2.Range("i3:j4")
    rngFilter(1, 1) = .Range("A3")
    rngFilter(1, 2) = .Range("D3")
    rngFilter(2, 1) = "'" & IIf(.Range("B1") = "<keine Auswahl>", "", .Range("B1"))
    rngFilter(2, 2) = "'<>"
    
    Bereich.AdvancedFilter xlFilterCopy, rngFilter, .Range("A3:G3")
    rngFilter.ClearContents
    
    LRow = .Cells(.Rows.Count, 3).End(xlUp).Row
    If LRow > 3 Then
        .Range("C4:C" & LRow).Offset(0, 5).FormulaR1C1 = _
        "=VLOOKUP(MID(RC3,5,FIND("" "",RC3,5)-FIND("" "",RC3)-1)*1,Codes!C5:C6,2,0)"
    End If
End With

End Sub

Gruß Tino

Beliebteste Forumthreads (12 Monate)

Makro läuft nach Datenerweiterung nicht mehr

27 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

27
Beiträge zum Forumthread

Beiträge zu diesem Forumthread