Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1352to1356
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
Inhaltsverzeichnis

Code von "Tino", Zeile kopieren wenn Wert gefunden

Code von "Tino", Zeile kopieren wenn Wert gefunden
20.03.2014 01:16:21
"Tino",
Hallo zusammen,
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

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Zeile kopieren wenn Wert gefunden
20.03.2014 10:14:16
Andre
Zu 1. habe ich das selbst hinbekommen, geht ja recht einfach mit oSh.Columns("Spalte:Spalte"). Hatte bisher nur die "" vergessen. Auch wenn dadurch die Zeilen teilweise doppelt kopiert werden, aber das stört nicht so sehr.
Zu 2. habe ich über rngDaten.EntireRow.Cells(1, 1).Copy zumindest geschafft jeweils die erste Zelle kopieren.
Mehrere Zellen müsste doch irgendwie ganz leicht gehen?

AW: Zeile kopieren wenn Wert gefunden
22.03.2014 16:51:10
Tino
Hallo,
durch zufall habe ich diesen Beitrag gesehen.
Habe die Function um diese Parameter erweitert
  • 1. wo gesucht werden soll

  • 2. welche Spalte kopiert werden soll

  • 3. Suchbegriff

  • 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
                    'Parameter SucheDaten 
                    '1. wo gesucht werden soll 
                    '2. welche Spalte kopiert werden soll 
                    '3. Suchbegriff 
                    Set rngDaten = SucheDaten(oSH.Columns("A:I"), "A:I", 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, strCopyBereich$, 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.EntireRow.Columns(strCopyBereich)
        '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.EntireRow.Columns(strCopyBereich), SucheDaten)
            Set rngFund = rngSucheIn.FindNext(rngFund)
        Loop
    End If
    
    End Function
    
    Gruß Tino

    Anzeige
    AW: Zeile kopieren wenn Wert gefunden
    23.03.2014 01:57:28
    Andre
    Hey freut mich dass du das hier gefunden hast :) Leider scheint das so nicht zu greifen, es wird trotzdem die ganze Zeile kopiert. Vllt kannst du direkt reinschauen, ich habe die Datei mal hochgeladen (dein Code mit der Anpassung ist schon enthalten): https://www.herber.de/bbs/user/89807.xlsm
    Gruß,
    Andre

    AW: Zeile kopieren wenn Wert gefunden
    23.03.2014 02:00:18
    Andre
    Hey freut mich dass du das hier gefunden hast :) Leider scheint das so nicht zu greifen, es wird trotzdem die ganze Zeile kopiert. Vllt kannst du direkt reinschauen, ich habe die Datei mal hochgeladen (dein Code mit der Anpassung ist schon enthalten): https://www.herber.de/bbs/user/89807.xlsm
    Gruß,
    Andre

    Anzeige
    AW: Zeile kopieren wenn Wert gefunden
    23.03.2014 11:52:59
    Tino
    Hallo,
    ja Du hast recht
    Mach aus der Zeile.
    rngDaten.EntireRow.Copy .Cells(lngNextRow, 1)
    
    diese
    rngDaten.Copy .Cells(lngNextRow, 1)
    
    Gruß Tino

    AW: Zeile kopieren wenn Wert gefunden
    23.03.2014 17:20:44
    Andre
    So läuft es danke vielmals!

    299 Forumthreads zu ähnlichen Themen

    Anzeige
    Anzeige
    Anzeige

    Beliebteste Forumthreads (12 Monate)

    Anzeige

    Beliebteste Forumthreads (12 Monate)

    Anzeige
    Anzeige
    Anzeige