Office: Excel VBA Bereich kopieren und in bereich einfuegen

MaxHeinemann · 13. Mai 2015

Freunde,

ich habe das Problem, dass ich mit Excel VBA eine Datenbank durchsuchen moechte und wenn der Suchbegriff einen treffer landet die ganze Spalte kopiert werden soll. Soweit ist mir das auch gelungen. Nun gelingt mir es jedoch nicht, dass dieser gefundene Bereich in einen bestimmten Bereich einer bestimmten Arbeitsmappe kopiert warden kann.

Code:

Code:
Sub Suchen()
Dim Zelle As Range
Dim Bereich As Range
Dim rngGefunden As Range
Dim Eingabe As String

Set Bereich = Range("A1:Z" & Cells(Rows.Count, 1).End(xlUp).Row) 'Suche bis letzte gefüllte Zelle in Spalte A

Eingabe = UCase(InputBox("Was soll gesucht werden?", "Suchbegriff"))

For Each Zelle In Bereich
If InStr(UCase(Zelle.Value), Eingabe) > 0 Then
If Not rngGefunden Is Nothing Then
Set rngGefunden = Union(rngGefunden, Rows(Zelle.Row))
Else
Set rngGefunden = Rows(Zelle.Row)
End If
End If
Next Zelle

If Not rngGefunden Is Nothing Then
rngGefunden.Select 'auswählen der gefundenen Zeilen
rngGefunden.Copy Sheet1.Cells(1, 1)
Else
MsgBox ">> " & Eingabe & "> " & Eingabe & "

:)
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

MaxHeinemann · 15. Mai 2015

Mit Code 1 z.B. kann ich jetz nach dem Suchbegriff "xy"suchen und alle Zeilen die "xy" enthalten warden dann in Arbeitsmappe "sheet2" kopiert.

Jedoch moechte ich jetzt auch den Suchbegriff "ab" und alle Zeilen die diesen Wert enthalten in die gleiche Mappe kopieren ist das nicht moeglich, da das vorangegangene ueberschrieben wird.

Ich suche nach 5 Begriffen und moechte in Arbeitsmappe "Sheet2"gerne 5 Bereiche makieren, wo diese Begriffe+Zeile gespeichert werden.

Vielen Dank im Vorraus. Hoffe ich konnte mich deutlich genug ausdruecken.

MaxHeinemann · 15. Mai 2015

Habe es jetzt geschafft die inhalte in einen bestimmten Bereich zu kopieren. Fragen die noch offen sind:

1. Wie kann ich die Arbeitsmappe bestimmen in welcher Gesucht wird. Momentan wird immer in der aktiven gesucht.

2. Wenn ich als Suchbegriff "Sch" eingebe, werden auch Zellen mit "Schmidt" kopiert. Wie kann ich das verhindern?

Bitte um eure Hilfe!

Code:

Sub Suchen()
Dim Zelle As Range
Dim Bereich As Range
Dim Bereich2 As Range
Dim rngGefunden As Range
Dim Eingabe As String

Set Bereich = sheet1.Range("A1:z" & Cells(Rows.Count, 1).End(xlUp).Row) 'Suche bis letzte gefüllte Zelle in Spalte A
With Worksheets("sheet2")
Set Bereich2 = Sheet2.Range("A5:A20")
End With

Eingabe = UCase(InputBox("Was soll gesucht werden?", "Suchbegriff"))

For Each Zelle In Bereich
If InStr(UCase(Zelle.Value), Eingabe) > 0 Then
If Not rngGefunden Is Nothing Then
Set rngGefunden = Union(rngGefunden, Rows(Zelle.Row))
Else
Set rngGefunden = Rows(Zelle.Row)
End If
End If
Next Zelle

If Not rngGefunden Is Nothing Then
rngGefunden.Select 'auswählen der gefundenen Zeilen
rngGefunden.Copy Bereich2

Else
MsgBox ">> " & Eingabe & "
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

xlph · 15. Mai 2015

Hallo max,

Code:

Sub Suchen()

Dim Zelle As Range
Dim QuellBereich As Range
Dim ZielZelle As Range
Dim rngGefunden As Range

Dim Eingabe As String
Dim Suchwerte() As String
Dim Index As Long
Dim Wert As String

Dim LetzteZeile As Long

Dim VergleichsArt As VbCompareMethod

VergleichsArt = vbTextCompare

With sheet1 ' QuellBlatt mit Überschrift
LetzteZeile = .Cells(.Rows.Count, 1).End(xlUp).Row ' Ermittelt die letzte gefüllte Zeile in Spalte A
Set QuellBereich = .Range("A2:Z" & LetzteZeile)
End With

With sheet2 ' ZielBlatt mit Überschrift
Set ZielZelle = .Range("A2")
.UsedRange.Offset(1).ClearContents ' Ziel säubern
End With

Do
Eingabe = InputBox("Was soll gesucht werden?" & String(2, vbLf) & _
"Suchwerte bitte getrennt durch" & vbLf & _
"ein Semikolon (;) eingeben.", "Suchbegriff")
If StrPtr(Eingabe) = 0 Then Exit Sub
Loop Until Len(Eingabe) > 0

If Left$(Eingabe, 1) = ";" Then Eingabe = Mid$(Eingabe, 2)
If Right$(Eingabe, 1) = ";" Then Eingabe = Left$(Eingabe, Len(Eingabe) - 1)

Suchwerte() = Split(Eingabe, ";")

For Each Zelle In QuellBereich
Wert = Zelle.Value

For Index = LBound(Suchwerte) To UBound(Suchwerte)

If StrComp(Wert, Suchwerte(Index), VergleichsArt) = 0 Then
If Not rngGefunden Is Nothing Then
Set rngGefunden = Union(rngGefunden, QuellBereich.Rows(Zelle.Row))
Else
Set rngGefunden = QuellBereich.Rows(Zelle.Row)
End If
End If

Next

Next Zelle

If Not rngGefunden Is Nothing Then
Application.Goto rngGefunden 'auswählen der gefundenen Zeilen
ZielZelle.Worksheet.Activate ' ZielBlatt aktivieren
rngGefunden.Copy ZielZelle
Else
MsgBox ">> " & Eingabe & "
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

MaxHeinemann · 15. Mai 2015

xlph,

vielen dank! Funktioniert super!

Eine Frage hab ich noch offen. Generell suche ich nach 5 Begriffen. Ist es moeglich, dass wenn ich nach Begriff 1 suche dieser in sheet2.Range1 gespeichert, Begriff 2 in sheet2.Range2 gepeichert wird .......

alternative: Das ich einen festgesetzen Suchbegriff habe. Dann koennte ich mir 5 buttons installieren und wuerde das Ergebnis je nach button woanders speichern.

MaxHeinemann · 15. Mai 2015

Jemmand eine Idee?

MaxHeinemann · 16. Mai 2015

Leute,

bin gerade echt am verzweifeln. Habe hier den code, wie von xlph empfohlen in meine excel mappe integriert und nach meinen Beduerfnissen umgebaut. Leider findet der code mir auch immer eine menge daten die nicht mit dem suchbegriff uebereinstimmen. Habe schon alles 100 mal geaendert aber finde leider nicht die Fehlerquelle.

Bitte um Hilfe!

Code:

Private Sub CommandButton2_Click()

Dim Zelle As Range
Dim QuellBereich As Range
Dim ZielZelle As Range
Dim rngGefunden As Range

Dim Eingabe As String
Dim Suchwerte() As String
Dim Index As Long
Dim Wert As String

Dim LetzteZeile As Long

Dim VergleichsArt As VbCompareMethod

VergleichsArt = vbTextCompare

With DPRsAeolus ' QuellBlatt mit Überschrift
LetzteZeile = .Cells(.Rows.Count, 1).End(xlUp).Row ' Ermittelt die letzte gefüllte Zeile in Spalte A
Set QuellBereich = .Range("a2:k" & LetzteZeile)
End With

With Times ' ZielBlatt mit Überschrift
Set ZielZelle = .Range("N3")
.Range("N3:x99").ClearContents ' Ziel säubern
End With

Do
Eingabe = InputBox("Was soll gesucht werden?" & String(2, vbLf) & _
"Suchwerte bitte getrennt durch" & vbLf & _
"ein Semikolon (;) eingeben.", "Suchbegriff", "SE.WTGP")
If StrPtr(Eingabe) = 0 Then Exit Sub
Loop Until Len(Eingabe) > 0

If Left$(Eingabe, 1) = ";" Then Eingabe = Mid$(Eingabe, 2)
If Right$(Eingabe, 1) = ";" Then Eingabe = Left$(Eingabe, Len(Eingabe) - 1)

Suchwerte() = Split(Eingabe, ";")

For Each Zelle In QuellBereich
Wert = Zelle.Value

For Index = LBound(Suchwerte) To UBound(Suchwerte)

If StrComp(Wert, Suchwerte(Index), VergleichsArt) = 0 Then
If Not rngGefunden Is Nothing Then
Set rngGefunden = Union(rngGefunden, QuellBereich.Rows(Zelle.Row))
Else
Set rngGefunden = QuellBereich.Rows(Zelle.Row)
End If
End If

Next

Next Zelle

If Not rngGefunden Is Nothing Then
Application.Goto rngGefunden 'auswählen der gefundenen Zeilen
ZielZelle.Worksheet.Activate ' ZielBlatt aktivieren
rngGefunden.Copy ZielZelle
Else
MsgBox ">> " & Eingabe & "
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

MaxHeinemann · 16. Mai 2015

Anbei auch mal meine Datei. Moechte mit dem CommandoButton(1) nach SE.WTG suchen und die ganze Zelle kopieren. Leider kopiert mir der Code immer mehr zellen als gewuenscht!

MaxHeinemann · 16. Mai 2015

Ware immer noch sehr dankbar wenn sich mir einer annehmen koennte und mal einen kurzen Blick auf meine Tabelle wirft!

Office: Excel VBA Bereich kopieren und in bereich einfuegen

Excel VBA Bereich kopieren und in bereich einfuegen

Excel VBA Bereich kopieren und in bereich einfuegen

Excel VBA Bereich kopieren und in bereich einfuegen

Excel VBA Bereich kopieren und in bereich einfuegen

Excel VBA Bereich kopieren und in bereich einfuegen - Similar Threads - Excel VBA Bereich

VBA: Platzhalter ersetzen und evtl. leere Zeile einfügen

Excel Range als Bild in Word einfügen

[Excel, VBA] Daten aus Excel-Bereich in Word Tabelle einfügen

VBA verschiedene definierte "nicht leere" Bereiche aus Datei kopieren in neue Datei

Bereich speichern als PDF speichern

Excel 2003 (VBA) Tabellenblatt Bereich als Email senden

Feststellen, ob Zelle in benanntem Bereich?