Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1012to1016
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
Suchfunktion um Kopierfunktion erweitern
25.09.2008 19:52:49
Axel
Hallo alle zusammen
ich brauch mal wieder euren guten Rat...
Ich möchte eine vorhandene Suchfunktion in meiner Tabelle um eine Kopierfunktion erweitern. (Link zur Tabelle mit Suchfunktion gibt's weiter unten)
Beispiel: Ich befinde mich in Zelle D10 und starte nun die Suchfunktion. Die Startzeile (10) ist sehr wichtig, und muss sich gemerkt werden, denn in diese Zeile solle die Werte der Suchfunktion kopiert werden.
Ich starte also in D10 die Suchfunktion und suche nach dem Begriff "Bingo". Gesucht wird nur in Spalte D. Ergebnisse: 4. In D5 kommt der begriff das erste mal vor, diese ist jedoch nicht die gewünschte Zeile, also weiter suchen lassen. In Zeile 8 (Zelle D8) kommt der Begriff "Bingo" abermals vor, dies ist die gewünschte Zeile. Ich drücke also bei Weitersuchen auf "Nein" und nun soll die Kopierfunktion aus Zeile 8 gestartet werden.
Die Kopierfunktion soll folgendes machen:
1.) Kopiere Kommentar von D8 nach (D-Startzeile) also D10, jedoch ohne den Zellinhalt von D10 zu verändern.
2.) Kopiere Zelle E8 nach (E-Startzeile) also E10
3.) Kopiere Zellen Z8-AC8 nach Z10-AC10
Wichtig: Es sollen nur die angegeben einzelnen Zellen (also keinesfalls die ganze Zeile ö.ä.) kopiert werden, die restlichen Inhalte der Zellen in Zeile 10 MÜSSEN erhalten bleiben!
Nach dem Kopiervorgang soll wieder in die Startzelle (D10) gesprungen werden.
Wenn nur ein Ergebnis gefunden wurde springt die Suchfunktion bisher ohne Nachfrage sofort dorthin, hier sollte noch eine Abfrage eingebaut werden ob dieses Ergebnis das gewünschte ist.
Ich hoffe ihr könnt mir wiedermal aus der Patsche helfen, ich habe die Suchfunktion und entsprechende Werte schonmal in eine Tabelle gepackt, ihr dürft sie nach Herzenslust modifizieren, Danke im Vorraus ;)
https://www.herber.de/bbs/user/55665.xls
Mfg Axel

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Suchfunktion um Kopierfunktion erweitern
26.09.2008 11:05:30
fcs
Hallo Axel,
hier mal dein Makro ergänzt um die Kopieraktionen, wobei ich einige Meldungen und deren Auswertung angepasst hab.
Gruß
Franz

Sub Suchen_und_anzeigen()
Dim Meldung As Long
Dim Suchen As Variant
Dim n%, x%, xZelle%, yZelle%
Dim Bereich$, Text$, Adresse$(), Akte$()
Dim Startzeile As Long
Dim wksAktiv As Worksheet
Startzeile = ActiveCell.Row
Set wksAktiv = ActiveSheet
Bereich = "D4:D10000"
'Suchbegriff eingeben
Suchen = InputBox("Bitte den zu suchenden Begriff eingeben." & vbCrLf & _
"ENTER ohne Wert = Abbruch", "Suche")
If Suchen = "" Then Exit Sub
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' letzte Zelle im Bereich ermitteln
With ActiveSheet.Range(Bereich)
xZelle = .Columns(.Columns.Count).Column
yZelle = .Rows(.Rows.Count).Row
End With
' Eigentlicher Suchvorgang
x = 1
With wksAktiv.Range(Bereich)
Set c = .Find(Suchen, After:=Cells(yZelle, xZelle), LookIn:=xlValues)
If Not c Is Nothing Then
ErsteAdresse = c.Address
Do
ReDim Preserve Adresse(x)
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
' Anzeige der Suchergebnisse
Text = vbCrLf
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 kein übereinstimmender Wert gefunden", _
vbOKOnly, "Suche")
Case 2
Range(Adresse(1)).Select
If MsgBox("Eine Zeile wurde gefunden. Zeile Kopieren?", vbYesNo, "Suche") = vbYes Then
Call Kopieren(wks:=wksAktiv, ZeileStart:=Startzeile, Zeile:=Range(Adresse(1)).Row)
End If
Case Else
For n = 1 To x - 1
Range(Adresse(n)).Select
Meldung = MsgBox("Insgesamt gibt es " & (x - 1) & _
" Übereinstimmungen!" & vbCrLf & "Drücke JA, um Zeile zu übernehmen" & vbLf _
& "Drücke NEIN um nächste Zeile zu suchen" & vbLf _
& "Drücke ABBRECHEN um abzubrechen", vbYesNoCancel, "Suche")
If Meldung = vbNo Then
'do nothing, weiter suchen
ElseIf Meldung = vbYes Then
'Daten in Startzeile kopieren
Call Kopieren(wks:=wksAktiv, ZeileStart:=Startzeile, Zeile:=Range(Adresse(n)).Row)
Exit For
ElseIf Meldung = vbCancel Then
Exit For
End If
Next n
End Select
Cells(ZeileStart, 4).Select
Application.Calculation = xlCalculationAutomatic
End Sub
Private Sub Kopieren(wks As Worksheet, ZeileStart&, Zeile&)
'Die Kopierfunktion soll folgendes machen:
With wks
'1.) Kopiere Kommentar von Dxx nach D-Startzeile
.Cells(Zeile, 4).Copy
.Cells(ZeileStart&, 4).PasteSpecial Paste:=xlPasteComments
'2.) Kopiere Zelle Exx nach (E-Startzeile)
.Cells(Zeile, 5).Copy Destination:=.Cells(ZeileStart&, 5)
'3.) Kopiere Zellen Zxx-ACxx nach Startzeile
.Range(.Cells(Zeile, 26), .Cells(Zeile, 29)).Copy Destination:=.Cells(ZeileStart, 26)
Application.CutCopyMode = False
End With
End Sub


Anzeige
AW: Suchfunktion um Kopierfunktion erweitern
27.09.2008 22:45:00
Axel
Bis auf den kleinen Flüchtigkeitsfehler in Zeile 77 perfekt! Genau so sollte es werden!
Viiiiielen Dank mal wieder ;)
Mfg Axel

299 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige