Microsoft Excel

Herbers Excel/VBA-Archiv

Zeilen auswählen und Kopieren | Herbers Excel-Forum


Betrifft: Zeilen auswählen und Kopieren von: Peter
Geschrieben am: 12.12.2009 16:11:19

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

  

Betrifft: AW: Zeilen auswählen und Kopieren von: Tino
Geschrieben am: 12.12.2009 16:58:24

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


  

Betrifft: zusatz Anmergung von: Tino
Geschrieben am: 12.12.2009 17:10:12

Hallo,
ich gehe davon aus,
dass dies in Deiner Tabelle gegeben ist das nach einem "x" auch eine Leere Zelle folgt.

Gruß Tino


  

Betrifft: AW: Zeilen auswählen und Kopieren von: Josef Ehrensberger
Geschrieben am: 12.12.2009 17:02:06

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



  

Betrifft: AW: Zeilen auswählen und Kopieren von: Peter
Geschrieben am: 12.12.2009 17:40:18

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


  

Betrifft: AW: Zeilen auswählen und Kopieren von: Peter
Geschrieben am: 12.12.2009 17:42:07

Zur korrektur
Die X stehen in Spalte a
Der Rest in Spalte B bis ende


  

Betrifft: AW: Zeilen auswählen und Kopieren von: Josef Ehrensberger
Geschrieben am: 12.12.2009 17:44:51

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



  

Betrifft: AW: Zeilen auswählen und Kopieren von: Peter
Geschrieben am: 12.12.2009 17:53:34

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


  

Betrifft: AW: Zeilen auswählen und Kopieren von: Josef Ehrensberger
Geschrieben am: 12.12.2009 18:00:54

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



  

Betrifft: AW: Zeilen auswählen und Kopieren von: Peter
Geschrieben am: 12.12.2009 18:08:56

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


Beiträge aus den Excel-Beispielen zum Thema "Zeilen auswählen und Kopieren"