Brauche nochmals eine Codeänderung
04.08.2006 12:52:16
Sonja
möchte mich bei u_ für die ausgezeichnete Hilfe von gestern bedanken. Da gibt es noch eine Kleinigkeit die mir im Magen liegt..
Habe ja diesen Suchcode:
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$, Inhalt()
' 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 <> "Auswahltabelle" 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)
ReDim Preserve Inhalt(x)
xTabelle(x) = Sheets(n).Name
Adresse(x) = c.Address(RowAbsolute:=False, ColumnAbsolute:=False)
Inhalt(x) = c.Value
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)
On Error Resume Next
With ActiveSheet
.Name = "Namensliste"
.[A1] = "BENUTZER"
.[B1] = "ZELLE"
.[C1] = "SUCHWORT: " & Begriff
For n = 1 To x - 1
.Cells(n + 1, 1) = xTabelle(n)
.Cells(n + 1, 2) = Adresse(n)
.Cells(n + 1, 3) = Inhalt(n)
Next n
End With
End Select
End Sub
Dieser wurde mir gestern von u_ bereits etwas erweitert, und es funktioniert auch tadellos wie es sollte.
Ich möchte diesen Code aber um noch ein kleines Detail erweitern. Und zwar listet mir ja der Suchdialog als Ergebnis folgendes auf:
Spalte A = Blattname
Spalte B = Zelle, wo der Begriff drinnen steht
Spalte C = Der genaue Wortlaut des Begriffes
Nun möchte ich zusätzlich haben, dass in Spalte D auch die Stückanzahl der jeweiligen Spalte aufscheint. Die Stückzahlen stehen in allen Blättern in der Spalte C, also sollte es dann so aussehen:
Spalte A = Blattname
Spalte B = Zelle, wo der Begriff drinnen steht
Spalte C = Der genaue Wortlaut des Begriffes
Spalte D = Stückanzahl
Soweit so gut, die Stückzahl sagt aus, das jemand etwas bekommen hat, nehmen wir mal an 5 Stück.
Dann sollte ja beim Suchergebnis des entsprechenden Blattnamens auch 5 als Ergebnis kommen. Jetzt wäre es aber auch möglich, dass die Person z.B.: 2 Stück zurück gegeben hat, die zurückgaben stehen in allen Blättern in der Spalte J.
Dann müsste mir der Suchdialog dies auch dementsprechend anzeigen, also wäre in diesem Fall das richtige Ergebnis bei Stückanzahl 3.
Ich hoffe auch das ist zu realisieren und stellt kein allzu grosses Problem dar. Ich danke allen die sich dieser Sache annehmen und mir weiter helfen.
Bin mittlerweile ja schon viel besser im Excel, dank dieses Forums, aber mit dem VBA Programmieren wirds wohl nie klappen, deshalb muss ich Euch bitten.
Mit freundlichen Grüssen Sonja