Re: Tabelle über Suchbegriffliste filtern

Am Sat, 09 Jul 2005 16:26:54 +0200 schrieb Mark Ise:

> Ich hab es inzwischen mit VBA hinbekommen, aber eine Formel mit VERWEIS,
> WENN, VERGLEICH, oder sowas wäre mir lieber.
>
>
> Hier mal meine Ergüsse:
> --------------------------------------
> Sub Suche_String(SearchS As Variant)
> ' Durchsucht einen Bereich nach einem String und markiert die Zeile,
> ' wenn der String gefunden wurde
>
> With Worksheets(1).Range("i2:i500")
> Set c = .Find(SearchS, LookIn:=xlValues)
> If Not c Is Nothing Then
> firstAddress = c.Address
> Do
> zeile = c.Row
> Cells(zeile, 14).Value = "1"
> Set c = .FindNext(c)
> Loop While Not c Is Nothing And c.Address <> firstAddress
> End If
> End With
> End Sub
> -------------------------------------
> Sub VergleicheMitListe()
>
> ' Lösche alte Werte
> Worksheets(1).Range("n2:n500").ClearContents
>
> Dim SuchString As Variant
>
> With Worksheets(2).Range("a2:a50")
> For Each d In .Value
> Suche_String (d)
> Next d
> End With
>
> End Sub
> --------------------------------------
>
> BTW: Ich hab für den Anfang Copy und Paste mit der Excelhilfe benutzt.
> Ansonsten hätte ich das nicht annähernd so hinbekommen.


Hallo Mark,

diese beiden Ansätze haben mich etwas irritiert, aber probier's trotzdem
mal so:

Sub Suche_String()
'******************
'Durchsucht einen Bereich nach Strings aus einer Liste
'und ersetzt den Inhalt der Zelle durch eine 1,
'wenn der String gefunden wurde.
'Wahlweise können dann die Zellen, die keine 1
'enthalten, min 0 (Null) überschriebeb werden.
'******************
Dim rngBer As Range, rngListe As Range
Dim LZelle As Range, c As Range
Dim firstaddress As String

Set rngBer = Application.InputBox _
(prompt:="Bitte Datenbereich markieren", Type:=8)
Set rngListe = Application.InputBox _
(prompt:="Bitte Listenbereich markieren", Type:=8)
'hier kannst Du entweder die Bereiche mit der Maus
'markieren oder sie von Hand eintippen

On Error Resume Next

For Each LZelle In rngListe
Set c = rngBer.Find(LZelle.Value, LookAt:=xlPart)
If Not c Is Nothing Then
firstaddress = c.Address
Do
c.Value = 1
Set c = rngBer.FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstaddress
End If
Next LZelle

'wenn die nicht-1-Zellen mit 0 (Null) überschrieben
'werden sollen, dann die folgenden auskommentierten
'Zeilen reaktivieren:
'Dim rngBZelle As Range
'For Each rngBZelle In rngBer
' If rngBZelle.Value <> 1 Then
' rngBZelle.Value = 0
' End If
'Next rngBZelle
End Sub


--
Gruß Eberhard
XL 2000
Eberhard(punkt)Funke(at)t-online.de
.

Relevant Pages

  • Re: Timer tickt nicht richtig
    ... 'wenn Datensatz in DataGrid selektiert ist, TabelleDG2 gefiltert ... Sub LoadDataset(ByVal OleDBConn As OleDb.OleDbConnection, ... ByVal Criteria2 As String, _ ... End If ...
    (microsoft.public.de.german.entwickler.dotnet.vb)
  • Re: Strukturiertes Programm
    ... >> (Die Sub ist schon vorhanden) ... >Dein Hauptproblem ist der Datentyp String Deines an die Sub übergebenen ... > End Enum ... >Private Function Fkt1() As String ...
    (microsoft.public.de.vb)
  • Re: Strukturiertes Programm
    ... > (Die Sub ist schon vorhanden) ... Dein Hauptproblem ist der Datentyp String Deines an die Sub übergebenen ... End Enum ... Private Function Fkt1() As String ...
    (microsoft.public.de.vb)
  • ADO
    ... Sub GetDataFromWorksheet(SourceFile As String, strSQL As String) ... On Error Resume Next ... End If ...
    (microsoft.public.de.access)
  • My Code: Invalid Procedure call or argument
    ... End Sub ... Dim strfile As String ... Dim strCurrentChar As String ... Move to the next character ...
    (comp.databases.ms-access)