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

Kopieren nach Kriterium

Kopieren nach Kriterium
Peter
Hallo Excel Gemeinde,
ich habe eine VBA Frage:
Auf "Tabellenblatt1" soll in Spalte G nach einem Text(teil), gesucht werden. Sobald dieser gefunden wird soll die gesammte Zeile nach "Tabellenblatt2" kopiert werden.
Bsp.:
Such-Kriterium: "Excel"
Zellentext in Spalte "G" kann auch Excelfreunde, Excelhasser etc. heissen.
Klingt eigentlich simpel, aber ich krieg es nicht gebacken. Kann mir jemand helfen?
Danke im voraus!
gruß
Peter

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

Betreff
Benutzer
Anzeige
Kopieren
14.09.2009 10:18:08
Backowe
Hallo Peter,
VBA-Code:
Sub Kopieren()
  Dim firstAddress As String
  Dim c As Range
  With Worksheets(1).Columns("G")
    Set c = .Find("Excel", LookIn:=xlValues, LookAt:=xlPart)
    If Not c Is Nothing Then
      firstAddress = c.Address
      Do
        With Worksheets(2)
          c.EntireRow.Copy _
            Destination:=.Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1)
        End With
        Set c = .FindNext(c)
      Loop While Not c Is Nothing And c.Address <> firstAddress
    End If
  End With
End Sub
Gruß Jürgen
AW: Kopieren
Peter

SUPER, vielen Dank Jürgen.
Deine Geschwindigkeit ist echt Wahnsinn.
Vielen Dank!
Zellformatierung mit übernehmen?
Peter

Hallo Jürgen,
vielen Dank für die wahnsinnig schnelle Hilfe!!!
Funktioniert prima - kann man die Formatierung auch noch mit übernehmen?
Vielen Dank nochmal
Mit Formatierung!
Backowe

Hallo Peter,
Sub Kopieren()
Dim firstAddress As String
Dim c As Range
With Worksheets(1).Columns("G")
Set c = .Find("Excel", LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
Do
With Worksheets(2)
c.EntireRow.Copy _
Destination:=.Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1)
c.EntireRow.Copy
.Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row).PasteSpecial Paste:= _
xlPasteFormats
Application.CutCopyMode = False
End With
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address  firstAddress
End If
End With
End Sub
Gruß Jürgen
Kleinere Schönheitsfehler
Peter

Hallo Jürgen,
vielen Dank für Deine erneute Hilfe. Deine Lösung funktioniert prima. Es stellte sich allerdings heraus, das bei mehrfachem Ausführen des Macros, Zeilen mehrfach übertragen werden - dies konnte ich selber durch das hinzufügen der Dim ws2 lösen.
Sub Kopieren()
Dim firstAddress As String
Dim ws2 As Worksheet
Dim c As Range
Set ws2 = Worksheets("Excel")
ws2.Columns.Clear
With Worksheets(1).Columns("G")
Set c = .Find("Excel", LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
Do
With Worksheets(2)
c.EntireRow.Copy _
Destination:=.Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1)
c.EntireRow.Copy
.Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row).PasteSpecial Paste:= _
xlPasteFormats
Application.CutCopyMode = False
End With
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address  firstAddress
End If
End With
End Sub
Ein Problem was bleibt ist der Zustand, dass die komplette Zeile übertragen wird. Ich kann also auf meinem "Worksheet2" nichts in einer Spalte dazuschreiben, weil das bei jeder Macroausführung wieder überschrieben wird.
1. Kann man das Kopieren der Zeile bis zu einer bestimmten Zeile begrenzen? (in meinem Fall Spalte M)
2. Ein zweiter kleiner Schönheitsfehler entsteht, dass im "Worksheet2" das beschreiben mit Zelle A2 beginnt. Ich würde gerne ein wenig mehr Platz haben (für Überschrift, etc.). Ändere ich nun Row +1 auf beispielsweise +2, fängt er zwar erst in Zelle A3 an, aber lässt auch zwischen jedem Eintrag eine Leerzeile. Wie kann man das lösen?
Danke & Gruß
Peter
Kleine Anpassung!
Backowe

Hi Peter,
wenn Du mehr Platz benötigst, schreibe in irgendeine Zelle in Spalte A etwas und das Makro fängt eine Zeile unterhalb an zu kopieren. Den Code habe ich auch angepasst, es wird jetzt nur noch der Bereich von A bis M übertragen.
Sub Kopieren()
Dim firstAddress As String
Dim ws2 As Worksheet
Dim c As Range
Worksheets(2).Cells.Clear
With Worksheets(1).Columns("G")
Set c = .Find("Excel", LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
Do
With Worksheets(2)
Range("A" & c.Row & ":M" & c.Row).Copy _
Destination:=.Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1)
Range("A" & c.Row & ":M" & c.Row).Copy
.Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row).PasteSpecial Paste:= _
xlPasteFormats
Application.CutCopyMode = False
End With
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address  firstAddress
End If
End With
End Sub
Gruß Jürgen
Anzeige
AW: Kopieren
14.09.2009 12:33:07
Peter
SUPER, vielen Dank Jürgen.
Deine Geschwindigkeit ist echt Wahnsinn.
Vielen Dank!
Zellformatierung mit übernehmen?
14.09.2009 16:01:25
Peter
Hallo Jürgen,
vielen Dank für die wahnsinnig schnelle Hilfe!!!
Funktioniert prima - kann man die Formatierung auch noch mit übernehmen?
Vielen Dank nochmal
Mit Formatierung!
14.09.2009 16:45:24
Backowe
Hallo Peter,
Sub Kopieren()
Dim firstAddress As String
Dim c As Range
With Worksheets(1).Columns("G")
Set c = .Find("Excel", LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
Do
With Worksheets(2)
c.EntireRow.Copy _
Destination:=.Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1)
c.EntireRow.Copy
.Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row).PasteSpecial Paste:= _
xlPasteFormats
Application.CutCopyMode = False
End With
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address  firstAddress
End If
End With
End Sub
Gruß Jürgen
Anzeige
Kleinere Schönheitsfehler
14.09.2009 21:53:02
Peter
Hallo Jürgen,
vielen Dank für Deine erneute Hilfe. Deine Lösung funktioniert prima. Es stellte sich allerdings heraus, das bei mehrfachem Ausführen des Macros, Zeilen mehrfach übertragen werden - dies konnte ich selber durch das hinzufügen der Dim ws2 lösen.
Sub Kopieren()
Dim firstAddress As String
Dim ws2 As Worksheet
Dim c As Range
Set ws2 = Worksheets("Excel")
ws2.Columns.Clear
With Worksheets(1).Columns("G")
Set c = .Find("Excel", LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
Do
With Worksheets(2)
c.EntireRow.Copy _
Destination:=.Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1)
c.EntireRow.Copy
.Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row).PasteSpecial Paste:= _
xlPasteFormats
Application.CutCopyMode = False
End With
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address  firstAddress
End If
End With
End Sub
Ein Problem was bleibt ist der Zustand, dass die komplette Zeile übertragen wird. Ich kann also auf meinem "Worksheet2" nichts in einer Spalte dazuschreiben, weil das bei jeder Macroausführung wieder überschrieben wird.
1. Kann man das Kopieren der Zeile bis zu einer bestimmten Zeile begrenzen? (in meinem Fall Spalte M)
2. Ein zweiter kleiner Schönheitsfehler entsteht, dass im "Worksheet2" das beschreiben mit Zelle A2 beginnt. Ich würde gerne ein wenig mehr Platz haben (für Überschrift, etc.). Ändere ich nun Row +1 auf beispielsweise +2, fängt er zwar erst in Zelle A3 an, aber lässt auch zwischen jedem Eintrag eine Leerzeile. Wie kann man das lösen?
Danke & Gruß
Peter
Anzeige
Kleine Anpassung!
14.09.2009 22:16:11
Backowe
Hi Peter,
wenn Du mehr Platz benötigst, schreibe in irgendeine Zelle in Spalte A etwas und das Makro fängt eine Zeile unterhalb an zu kopieren. Den Code habe ich auch angepasst, es wird jetzt nur noch der Bereich von A bis M übertragen.
Sub Kopieren()
Dim firstAddress As String
Dim ws2 As Worksheet
Dim c As Range
Worksheets(2).Cells.Clear
With Worksheets(1).Columns("G")
Set c = .Find("Excel", LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
Do
With Worksheets(2)
Range("A" & c.Row & ":M" & c.Row).Copy _
Destination:=.Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row + 1)
Range("A" & c.Row & ":M" & c.Row).Copy
.Range("A" & .Cells(.Rows.Count, "A").End(xlUp).Row).PasteSpecial Paste:= _
xlPasteFormats
Application.CutCopyMode = False
End With
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address  firstAddress
End If
End With
End Sub
Gruß Jürgen
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige