ich habe hier aus dem Forumsarchiv einen Code von "Tino" entdeckt, der genau das macht, was ich gesucht habe. Es wird im Prinzip nach einem Wert in einer Spalte gesucht und die dazugehörige Zeile in einem anderen Blatt eingefügt.
Ich würde jedoch gerne nicht nur eine Spalte, sondern mehrere Spalten nach diesem Suchbegriff durchsuchen, und nicht nur die ganze Zeile sondern nur ganz bestimmte Spalten (A bis I) kopieren und einfügen.
Link zum Archiv: https://www.herber.de/forum/archiv/1184to1188/1185237_EXCEL_2010_Wiedergabe_ganzer_Datensaetze.html
Um einen bestimmten Spaltenbereich habe ich bereits das hier probiert:
Range("A" & rngDaten.Row & ":I" & rngDaten.Row).Copy
Kopiert dann leider gar keine Zeilen. Komme leider auch sonst nicht weiter. Wäre euch sehr dankbar!
Gruß, Andre
Sub Test()
Dim oSH As Worksheet, rngDaten As Range
Dim strSuchBegriff$
Dim lngNextRow As Long
Dim iCalc As Integer
strSuchBegriff = "offen"
With Application
'Bildschirmaktualisierung, Eventmakros ausschalten
'Berechnung in einer Variable merken u. auf manuell stellen
'Dies bewirkt das der Bildschirm nicht so flackert und das der Code stabiler u. schneller lä _
_
uft
iCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
With Sheets("offene Punkte")
'Tabelle leer machen ab A12 bis Ende Tabelle Spalte V
.Range("A12", .Cells(.Rows.Count, 22)).ClearContents
'erste einfüge Zeile, wo die erste gefundene Zeile reinkommt. (hier Zeile 12)
lngNextRow = 12
'Schleife über alle Tabellen
For Each oSH In ThisWorkbook.Worksheets
'Namen der Tabelle prüfen mit Musterübereinstimmung Name muss Whg Zahl.Zahl sein
'siehe auch in der VBA Hilfe unter 'Like (Operator)'
If oSH.Name Like "Whg #.#" Then
'Suche in Spalte V auf Tabelle oSh die Zellen mit dem Suchbegriff in _
strSuchBegriff
Set rngDaten = SucheDaten(oSH.Columns(22), strSuchBegriff)
If Not rngDaten Is Nothing Then 'gefunden?
For Each rngDaten In rngDaten.Areas 'gehe alle zusammenhängende Zellen _
durch
'kopiere die komplette Zeilen nach offene Punkte
rngDaten.EntireRow.Copy .Cells(lngNextRow, 1)
'Zähler für nächste Zeile
lngNextRow = lngNextRow + rngDaten.Rows.Count
Next rngDaten
End If
End If
Next
End With
'Bildschirmaktualisierung, Eventmakros wieder einschalten
'Berechnung auf den alten Zustand zurückstellen
.Calculation = iCalc
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function SucheDaten(rngSucheIn As Range, strSucheNach$) As Range
Dim strErste$, rngFund As Range
'Suche Zellen mit dem Wert in strSucheNach
Set rngFund = rngSucheIn.Find(What:=strSucheNach, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'wurde eine Zelle gefunden?
If Not rngFund Is Nothing Then
'merke diese erste Adresse
strErste = rngFund.Address
'speichere diese in SucheDaten
Set SucheDaten = rngFund
'suche nächste mit diesem Begriff
Set rngFund = rngSucheIn.FindNext(rngFund)
'Schleife bis wieder die erste gefundene gefunden wird
Do While strErste rngFund.Address
Set SucheDaten = Union(rngFund, SucheDaten)
Set rngFund = rngSucheIn.FindNext(rngFund)
Loop
End If
End Function