Abfragenproblem - Adressenliste @ Thomas Haß

Hallo an Alle,
da der Thread vom 24.10.2007 (Abfragenproblem - Adressenliste) mittlerweile im Archiv gelandet ist (https://www.herber.de/forum/archiv/916to920/t919310.htm), musste ich ein neues Thema öffnen.
Hallo Thomas Haß,
vielen Dank für Deinen Bemühungen. Sowohl Deine erste Version als auch die zweite Version arbeiten einwandfrei. Hatte mit Hilfe des Makrorekorders die Ergänzungen, die Du mit der zweiten Version implemtiert hast, zwischenzeitlich selbst hinbekommen.
Bedingt durch meine Datensätze und die Methode von Dir kommt es jedoch manchmal zu doppelten Datensätzen: Wenn man den Nachmanen eingibt, wird der Datensatz zweimal geschrieben, wenn der Nachname auch nochmal in der Email-Adresse vorkommt.
Ich gehe mal davon aus, dass es sehr aufwendig ist, diese Erweiterung einzubauen.
Daher bin ich mit der von Dir erstellten Lösung sehr zufrieden.
Björn

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Björn,
so Aufwendig ist das garnicht. Man muß nur die Fundstelle mit der letzten Fundstelle vergleichen, ist die Zeilennummer die selbe, braucht diese nicht noch einmal eingetragen werden. Habe das so abgeändert:


Sub Stichwort()
Application.ScreenUpdating = False
Range("B5:K65536").Select 'B:K = 10 Spalten, mußt du anpassen...
Range("B5").Activate
Selection.ClearContents
[B4].Select
If Sheets(2).[B2] = "" Or Sheets(2).[B2] = " " Then Exit Sub
Dim rng As Range
Dim sAddress As String
Dim rowFund As Integer, rowEintrag As Integer, rowMerke As Integer
Set rng = Sheets(1).Cells.Find(what:=Sheets(2).[B2], LookIn:=xlValues, MatchCase:=False) _
If Not rng Is Nothing Then
sAddress = rng.Address
rowFund = rng.Row
rowEintrag = 5
Do
Application.Goto rng, True
'hier werden die gefundenen Daten eingetragen. Die Zahlen stehen für Spalte,
'also 1=A, 2=B usw. Hier mußt du anpassen
If rowMerke  rowFund Then
rowMerke = rowFund
Sheets(2).Cells(rowEintrag, 2) = Cells(rowFund, 1).Text
Sheets(2).Cells(rowEintrag, 3) = Cells(rowFund, 2).Text
Sheets(2).Cells(rowEintrag, 4) = Cells(rowFund, 3).Text
Sheets(2).Cells(rowEintrag, 5) = Cells(rowFund, 4).Text
Sheets(2).Cells(rowEintrag, 6) = Cells(rowFund, 5).Text
Sheets(2).Cells(rowEintrag, 7) = Cells(rowFund, 6).Text
Sheets(2).Cells(rowEintrag, 8) = Cells(rowFund, 7).Text
Sheets(2).Cells(rowEintrag, 9) = Cells(rowFund, 8).Text
Sheets(2).Cells(rowEintrag, 10) = Cells(rowFund, 9).Text
Sheets(2).Cells(rowEintrag, 11) = Cells(rowFund, 10).Text
End If
'bis hier muß angepasst werden. Gesucht wird im gesammten Blatt 1.
Set rng = Cells.FindNext(after:=ActiveCell)
If rng.Address = sAddress Then Exit Do
rowFund = rng.Row
rowEintrag = rowEintrag + 1
Loop
End If
Set rng = Nothing
Sheets(2).Select
[B4].Select
Application.ScreenUpdating = True
End Sub

Hoffe das wars auch gewesen, Tschüß Thomas

Beliebteste Forumthreads (12 Monate)

Abfragenproblem - Adressenliste @ Thomas Haß

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread