Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
784to788
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
784to788
784to788
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Suchfunktion per VBA / Ergebnis kopieren

Suchfunktion per VBA / Ergebnis kopieren
25.07.2006 22:52:16
Erich
Hallo EXCEL-Freunde,
mit der Recherche aus dem Forum habe ich einen Code gebastelt der folgendes kann:
1. Prüfen ob eine Tabelle mit dem Namen "Gefunden" besteht; ggfls. neu anlegen
2. Im Bereich D212:D231 einer bestimmten "Suchtabelle" (hier: D_1BL) einen Wert "O" suchen.
3. Alle Zeilen mit diesem Wert in der Spalte D in das Blatt "Gefunden" kopieren.
Jetzt hätte ich gerne folgende Änderung:
Nicht die komplette Zeile kopieren wenn "O" in der Spalte D vorhanden, sondern nur die Zellen der
- Spalte B
- Spalte D
- Spalte E
- Spalte F
und dann eintragen in die Tabelle "Gefunden" in die Spalten
- A (vorher B)
- B (vorher D)
- C (vorher E)
- D (vorher F)
Hier der Code:

Sub aMusteraufl()
Dim Tab1 As Worksheet, Tab2 As Worksheet
Dim Auswahl As String, myWert1 As String, mySpalte As Integer
Dim gefunden As Boolean
Dim Zelle As Range, Tb(1 To 15) As Worksheet, zeile As Long
Dim wks As Worksheet, rng As Range
Dim sAddress As String, sFind As String
Dim Cr As Long, tarWks As String
myWert1 = "O" 'Suchbegriff Wert
mySpalte = 4 'Suchspalte in Suchtabelle
Sheets("D_1BL").Select
Range("A1").Select
Set Tab1 = Sheets("D_1BL") ' = Ausgangstabelle, Suchtabelle
TabAuswahl ' prüfen ob Tabelle "Gefunden" vorhanden
Sheets("Gefunden").Cells.Clear
Sheets("Gefunden").Cells(1, 1) = "Der Wert " & Auswahl & " " & myWert1 & _
" wurde in der Tabelle D_1BL" & _
", in der Spalte " & mySpalte & " gefunden"
Sheets("Gefunden").Cells(2, 1) = "'"
Set Tab2 = Sheets("Gefunden") ' = Eingabetabelle
sFind = myWert1
If sFind = "" Then Exit Sub
tarWks = "Gefunden" ' Zieltabelle
Cr = 65536
If Worksheets(tarWks).Cells(Cr, 1) = "" Then
Cr = Worksheets(tarWks).Cells(Cr, 1).End(xlUp).Row
End If
If Cr = 2 Then Cr = 3
Set wks = Worksheets("D_1BL")
Set rng = wks.Range("D212:D231").Find(What:=sFind, LookAt:=xlWhole, LookIn:=xlValue)
If Not rng Is Nothing Then
sAddress = rng.Address
Do
Application.Goto rng, True
wks.Rows(rng.Row).Copy Destination:=Worksheets(tarWks).Rows(Cr)
wks.Rows(rng.Row).Copy
Worksheets(tarWks).Rows(Cr).PasteSpecial Paste:=xlValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Cr = Cr + 1
Set rng = wks.Range("D212:D231").FindNext(After:=ActiveCell)
If rng.Address = sAddress Then Exit Do
Loop
End If
Sheets("Gefunden").Select
End Sub
Sub TabAuswahl() ' prüfen ob neue Tabelle angelegt werden muss
Dim Sh As Worksheet
Dim sName$
sName = "Gefunden"
For Each Sh In Worksheets
If InStr(Sh.Name, sName) > 0 Then
Sh.Select
Exit Sub
End If
Next Sh
Sheets.Add.Name = ("Gefunden")
End Sub

Besten Dank für eine Hilfe!
mfg
Private Tippgemeinschaft für Lotto oder KENO: http://www.kenostrategen.de

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
ERLEDIGT
26.07.2006 08:16:43
Erich
habe eine einfachere Lösung gefunden; siehe Thread weiter oben:
bestimmte Zellen kopieren
mfg
Private Tippgemeinschaft für Lotto oder KENO: http://www.kenostrategen.de
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige