Live-Forum - Die aktuellen Beiträge
Datum
Titel
19.04.2024 19:41:34
Bei VBA Ausführung Anzeige einfrieren
19.04.2024 17:05:40
Zählen von Zeilen, in denen in bestimmten Bereich Daten sind
19.04.2024 16:34:52
gemeinsamer Filter über drei Spalten
19.04.2024 15:39:42
Exceltabelle daten per combobox zu word Datei
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1120to1124
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
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1120to1124
1120to1124
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Zeilen auswählen und Kopieren

Zeilen auswählen und Kopieren
Peter
Hallo Freunde ich brauche wieder mal eure Hilfe
Mit folgendem VBA suche ich Zeilen in den in Spalte A ein X steht, dann kopiere ich diese und die nächste Zeile und füge sie in ein anderes Tabellenblatt ein.
Mein Anliegen währe nicht nur die zwei Zeilen zu kopieren sondern von der Zeile mit dem X bis zur nächsten leerzeile.
Vielleich kann mir jemand das Makro dafür anpassen.
Sub LV_übertragen()
Dim lRead As Long, lWrite As Long
lWrite = 1
For lRead = 1 To 5000
If Worksheets("Stamm-LV").Cells(lRead, 1) = "x" Then
Worksheets("Stamm-LV").Range("B" & lRead & ":H" & lRead + 1).Copy
Worksheets("Zwischentabelle").Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial
End If
Next lRead
Application.CutCopyMode = False
End Sub
Ich bitte um Ihre hilfe

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Zeilen auswählen und Kopieren
12.12.2009 16:58:24
Tino
Hallo,
kannst ja mal testen.
Sub LV_übertragen()
Dim Bereich As Range
Dim rngX As Range, rngLeer As Range
Dim rngUnion As Range
Dim Erste As Long

With Sheets("Stamm-LV")
 Set Bereich = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0))
End With


'Zellen mit x sammeln ********** 
Set rngX = Bereich.Find("x", Bereich(Bereich.Rows.Count, 1), LookIn:=xlValues, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)

If Not rngX Is Nothing Then
    Erste = rngX.Row
    Do
        If Not rngUnion Is Nothing Then
         Set rngUnion = Union(rngUnion, rngX)
        Else
         Set rngUnion = rngX
        End If
        Set rngX = Bereich.FindNext(rngX)
    Loop While rngX.Row <> Erste
'******************************** 


    Set rngX = rngUnion
    Set rngUnion = Nothing

'Zellen mit Leer ab der Zelle mit x Suchen +++++++++++++ 
    For Each rngX In rngX
     Set rngLeer = Bereich.Find("", rngX, LookIn:=xlValues)
     If Not rngLeer Is Nothing Then
        If Not rngUnion Is Nothing Then
          Set rngUnion = Union(rngUnion, Range(rngX.Offset(0, 1), rngLeer.Offset(0, 7)))
        Else
          Set rngUnion = Range(rngX.Offset(0, 1), rngLeer.Offset(0, 7))
        End If
     End If
    Next rngX
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 

'Daten kopieren 
    If Not rngUnion Is Nothing Then
        With Worksheets("Zwischentabelle")
         rngUnion.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(2, 0)
        End With
    End If

End If
End Sub
Gruß Tino
Anzeige
zusatz Anmergung
12.12.2009 17:10:12
Tino
Hallo,
ich gehe davon aus,
dass dies in Deiner Tabelle gegeben ist das nach einem "x" auch eine Leere Zelle folgt.
Gruß Tino
AW: Zeilen auswählen und Kopieren
12.12.2009 17:02:06
Josef
Hallo Peter,
ungetestet.
Sub LV_übertragen()
  Dim lngRow As Long, lngLast As Long
  
  With Worksheets("Stamm-LV")
    Do While lngRow <= 5000
      lngRow = lngRow + 1
      If .Cells(lngRow, 1) = "x" Then
        lngLast = lngRow + 1
        
        Do While .Cells(lngLast, 1) <> "" And .Cells(lngLast, 1) <> "x"
          lngLast = lngLast + 1
        Loop
        
        .Range(.Cells(lngRow, 2), .Cells(lngLast, 8)).Copy
        
        Worksheets("Zwischentabelle").Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial
        
        lngRow = lngLast + 1
      End If
    Loop
  End With
  
  Application.CutCopyMode = False
  
End Sub


Gruß Sepp

Anzeige
AW: Zeilen auswählen und Kopieren
12.12.2009 17:40:18
Peter
Hallo
Die Makros funtionieren alle aber sie kopieren immer nur 2 Zelen
Manchmal ist es nur eine, aber manchmal auch mehrere und es sollen die Zeilen in dem das x steht bis zu Lehrzeile kopiert werden. Aber ohne dem x selber.
x Test Test Test Test Test
Test Test Test Test Test
x Test Test Test Test Test
Test Test Test Test Test
Test Test Test Test Test
x Test Test Test Test Test
Test Test Test Test Test
Test Test Test Test Test
Test Test Test Test Test
Ich bitte nochmal um Ihre Unterstützung
Gruß Peter
AW: Zeilen auswählen und Kopieren
12.12.2009 17:42:07
Peter
Zur korrektur
Die X stehen in Spalte a
Der Rest in Spalte B bis ende
Anzeige
AW: Zeilen auswählen und Kopieren
12.12.2009 17:44:51
Josef
Hallo Peter,
dann probier mal so.
Sub LV_übertragen()
  Dim lngRow As Long, lngLast As Long
  
  With Worksheets("Stamm-LV")
    Do While lngRow <= 5000
      lngRow = lngRow + 1
      If .Cells(lngRow, 1) = "x" Then
        lngLast = lngRow + 1
        
        Do While .Cells(lngLast, 2) <> "" And .Cells(lngLast, 1) <> "x"
          lngLast = lngLast + 1
        Loop
        
        .Range(.Cells(lngRow + 1, 2), .Cells(lngLast, 8)).Copy
        
        Worksheets("Zwischentabelle").Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial
        
        lngRow = lngLast + 1
      End If
    Loop
  End With
  
  Application.CutCopyMode = False
  
End Sub


Gruß Sepp

Anzeige
AW: Zeilen auswählen und Kopieren
12.12.2009 17:53:34
Peter
Hallo noch mal
So ist es schon gut, aber die Zeile in der das x steht muß auch noch dazu. aber ohne dem x
Gruß Peter
AW: Zeilen auswählen und Kopieren
12.12.2009 18:00:54
Josef
Hallo Peter,
das hättest du aber selber auch anpassen können!
Sub LV_übertragen()
  Dim lngRow As Long, lngLast As Long
  
  With Worksheets("Stamm-LV")
    Do While lngRow <= 5000
      lngRow = lngRow + 1
      If .Cells(lngRow, 1) = "x" Then
        lngLast = lngRow + 1
        
        Do While .Cells(lngLast, 2) <> "" And .Cells(lngLast, 1) <> "x"
          lngLast = lngLast + 1
        Loop
        
        .Range(.Cells(lngRow, 2), .Cells(lngLast, 8)).Copy
        
        Worksheets("Zwischentabelle").Cells(Rows.Count, 1).End(xlUp).Offset(2, 0).PasteSpecial
        
        lngRow = lngLast + 1
      End If
    Loop
  End With
  
  Application.CutCopyMode = False
  
End Sub

Gruß Sepp

Anzeige
AW: Zeilen auswählen und Kopieren
12.12.2009 18:08:56
Peter
Hallo Josef
Ich versuche es natürlich auch selber, bin aber längst nicht so gut in VBA.
Deswegen versuche ich alles was ich kriege zu erhaschen.
Vielen Dank nochmal für Deine und Eure Hilfe
Mit freundliche Grüßen
Peter Steiner

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige