Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
628to632
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
628to632
628to632
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Suchkriterium ändern - 2. Versuch

Suchkriterium ändern - 2. Versuch
25.06.2005 17:57:14
Rausch
Hallo nochmals,
ich habe gestern den Code erhalten der fast so arbeitet wie ich das gerne hätte, bin aber erst heute drauf gekommen, dass es nicht ganz so ist. Ich möchte das das Suchergebnis nicht im gleichen, sondern in einer neuen Arbeitsmappe geöffnet wird. Für mich stellt das ein riesen Problem dar und hoffe das du mir nochmals helfen kannst.
Hier der bereits existierende Code (wo das Ergebnis in der gleichen Mappe ist)
Option Base 1
Option Compare Text

Sub Suchen_und_anzeigen()
Dim Meldung         As Byte, Pos        As Byte
Dim Schleife        As Byte, y          As Byte
Dim Begriff, Suchen()                   As Variant
Dim Bereich                             As Range
Dim n%, x%, xZelle%, yZelle%
Dim xTabelle$(), Adresse$(), Text$
' Suchbegriff eingeben
Begriff = InputBox _
("Suchwort eingeben." & vbCrLf & _
"Willst Du Abbrechen,einfach Enter drücken", "S U C H M O D U S")
If Begriff = "" Then Exit Sub
Pos = InStr(Begriff, "+")
If Pos Then
ReDim Suchen(2)
Suchen(1) = Left(Begriff, Pos - 1)
Suchen(2) = Right(Begriff, Len(Begriff) - Pos)
Schleife = 2
Else
ReDim Suchen(1)
Suchen(1) = Begriff
Schleife = 1
End If
Application.ScreenUpdating = False
' Eigentlicher Suchvorgang (in allen Tabellenblättern)
x = 1
For y = 1 To Schleife
For n = 1 To Sheets.Count
' Letzte Zelle des Bereiches ermitteln. Diese Zelle wird als Startzelle für
' die Suche deffiniert, da Suche nach dieser Zelle, also in erster Zelle
' des Bereiches beginnt.
'Bereich festlegen
Set Bereich = Worksheets(n).UsedRange
With Worksheets(n).Range(Bereich.Address)
xZelle = .Columns(.Columns.Count).Column
yZelle = .Rows(.Rows.Count).Row
End With
With Sheets(n).Range(Bereich.Address)
Set c = .Find(Suchen(y), after:=Cells(yZelle, xZelle), LookIn:=xlValues)
If Not c Is Nothing Then
ErsteAdresse = c.Address
Do
ReDim Preserve Adresse(x): ReDim Preserve xTabelle(x)
xTabelle(x) = Sheets(n).Name
Adresse(x) = c.Address(RowAbsolute:=False, ColumnAbsolute:=False)
Set c = .FindNext(c)
x = x + 1
Loop While Not c Is Nothing And c.Address <> ErsteAdresse
End If
End With
Next n
Next y
Application.ScreenUpdating = True
' Die Anzahl der gefundenen Werte ist (x - 1), wenn keiner
' gefunden wurde dann ist x = 1
Select Case x
Case 1
Meldung = MsgBox("Es wurde leider Nix gefunden", _
vbOKOnly, "G E F U N D E N E   W E R T E")
Exit Sub
Case Else
Meldung = MsgBox("Hurra " & (x - 1) & " Übereinstimmungen gefunden.", _
vbOKOnly, "G E F U N D E N E   W E R T E")
'Tabelle einfügen
Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
On Error Resume Next
With ActiveSheet
.Name = "Suchergebnis"
.[A1] = "Geräteart"
.[B1] = "In der Zelle"
For n = 1 To x - 1
.Cells(n + 1, 1) = xTabelle(n)
.Cells(n + 1, 2) = Adresse(n)
Next n
End With
End Select
End Sub

Kleiner Nachtrag noch;
ich habe da ein Tabellenblatt mit dem Namen "Auswahlliste" und möchte das diese
bei der Suche nicht mit einbezogen wird, dass heisst wenn auf allen Blättern 11 Ergebnisse gefunden werden, dann darf dies nur auf jenen, die nicht "Auswahlliste" heissen, passieren.
Danke mfg Kurt

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Suchkriterium ändern - 2. Versuch
25.06.2005 18:32:09
Klaus
Hallo Kurt,
so müßte es eigentlich funktionieren.Es öffnet sich eine neu Arbeitsmappe, die du dann weiterverarbeiten kannst. Die Änderungen sind fett hervorgehoben:

Option Base 1
Option Compare Text
Sub Suchen_und_anzeigen()
Dim Meldung         As Byte, Pos        As Byte
Dim Schleife        As Byte, y          As Byte
Dim Begriff, Suchen()                   As Variant
Dim Bereich                             As Range
Dim n%, x%, xZelle%, yZelle%
Dim xTabelle$(), Adresse$(), Text$
' Suchbegriff eingeben
Begriff = InputBox _
("Suchwort eingeben." & vbCrLf & _
"Willst Du Abbrechen,einfach Enter drücken", "S U C H M O D U S")
If Begriff = "" Then Exit Sub
Pos = InStr(Begriff, "+")
If Pos Then
ReDim Suchen(2)
Suchen(1) = Left(Begriff, Pos - 1)
Suchen(2) = Right(Begriff, Len(Begriff) - Pos)
Schleife = 2
Else
ReDim Suchen(1)
Suchen(1) = Begriff
Schleife = 1
End If
Application.ScreenUpdating = False
' Eigentlicher Suchvorgang (in allen Tabellenblättern)
x = 1
For y = 1 To Schleife
For n = 1 To Sheets.Count

If Sheets(n).Name "Auswahlliste" Then

' Letzte Zelle des Bereiches ermitteln. Diese Zelle wird als Startzelle für
' die Suche deffiniert, da Suche nach dieser Zelle, also in erster Zelle
' des Bereiches beginnt.
'Bereich festlegen
Set Bereich = Worksheets(n).UsedRange
With Worksheets(n).Range(Bereich.Address)
xZelle = .Columns(.Columns.Count).Column
yZelle = .Rows(.Rows.Count).Row
End With
With Sheets(n).Range(Bereich.Address)
Set c = .Find(Suchen(y), after:=Cells(yZelle, xZelle), LookIn:=xlValues)
If Not c Is Nothing Then
ErsteAdresse = c.Address
Do
ReDim Preserve Adresse(x): ReDim Preserve xTabelle(x)
xTabelle(x) = Sheets(n).Name
Adresse(x) = c.Address(RowAbsolute:=False, ColumnAbsolute:=False)
Set c = .FindNext(c)
x = x + 1
Loop While Not c Is Nothing And c.Address <> ErsteAdresse
End If
End With
End If

Next n
Next y
Application.ScreenUpdating = True
' Die Anzahl der gefundenen Werte ist (x - 1), wenn keiner
' gefunden wurde dann ist x = 1
Select Case x
Case 1
Meldung = MsgBox("Es wurde leider Nix gefunden", _
vbOKOnly, "G E F U N D E N E   W E R T E")
Exit Sub
Case Else
Meldung = MsgBox("Hurra " & (x - 1) & " Übereinstimmungen gefunden.", _
vbOKOnly, "G E F U N D E N E   W E R T E")
'Tabelle einfügen
'ALTER CODE: Worksheets.Add.Move after:=Worksheets(Worksheets.Count)

Workbooks.Add

On Error Resume Next
With ActiveSheet
.Name = "Suchergebnis"
.[A1] = "Geräteart"
.[B1] = "In der Zelle"
For n = 1 To x - 1
.Cells(n + 1, 1) = xTabelle(n)
.Cells(n + 1, 2) = Adresse(n)
Next n
End With
End Select
End Sub

Gruß Klaus
Anzeige
AW: Suchkriterium ändern - 2. Versuch
25.06.2005 20:01:04
Rausch
Hallo KLaus,
ja das gewünschte Tabellenblatt wird ausgelassen, jedoch ist in der neuen Mappe keine Auflistung mehr vorhanden, so wie beim alten Code.
Kannst Du mir da nochmals helfen?
mfg Kurt
Nachtrag
25.06.2005 18:56:17
Klaus
Hallo Kurt,
bitte stelle deine Frage nur einmal ins Forum und nicht viermal !
Es beschäftigen sich nämlich sonst unter Umständen mehrere verschiedene Leute nur mit deinem Problem, obwohl es weiter oben vielleicht schon gelöst wurde.
Viele Leute beantworten solche Fragen dann nicht mehr, obwohl sie es könnten !
Wenn die Frage noch nicht beantwortet wurde, so kann du dein Problem über
"Frage noch offen" weiter unter "Offene Fragen" sichtbar halten.
Gruß Klaus
Anzeige
AW: Suchkriterium ändern - 2. Versuch
25.06.2005 19:24:18
Rausch
Danke Klaus für deine antwort.
Werde mir deinen nachtrag zu herzen nehmen und nichts mehr doppelt einstellen.
Schönen abend noch
mfg Kurt
AW: Suchkriterium ändern - 2. Versuch
26.06.2005 12:12:12
Rausch
Danke, mein Problem hat sich erledigt.
mfg Kurt

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige