Microsoft Excel

Herbers Excel/VBA-Archiv

Jede 2 Zeile in neues Register kopieren

Betrifft: Jede 2 Zeile in neues Register kopieren von: Arthur
Geschrieben am: 19.11.2012 14:07:55

Guten Tag zusammen

Ich habe eine Liste in Tabellenblatt 1: diese soll aufgeteilt werden in Tabellenblatt 2 und Tabellenblatt 3 (Tabellenblätter existieren noch nicht)
Jede 2. Zeile in TB 2 und der Rest in Tabellenblatt 3.

https://www.herber.de/bbs/user/82678.xlsx

Kann mir jemand helfen und ein kleines oder grosses Makro schreiben, dass ich komfortabel zu meinem Ziel komme?

Ev schon mit Text in Spalten (siehe Beispiel) miteinbeziehn falls dies geht

Herzlichen Dank für eure Hilfe!

Gruss
Arthur

  

Betrifft: AW: Jede 2 Zeile in neues Register kopieren von: Rudi Maintaire
Geschrieben am: 19.11.2012 14:31:49

Hallo,
in B3: =Rest(Zeile();2), runter kopieren, nach 1 filtern ind in Tabelle2 kopieren.

Gruß
Rudi


  

Betrifft: AW: Jede 2 Zeile in neues Register kopieren von: Klaus M.vdT.
Geschrieben am: 19.11.2012 14:33:05

Hi Arthur,

das haut auf deinem Beispielblatt hin, probiers mal aus.

Option Explicit

Sub Aufteilen()

Dim wksSource As Worksheet
Dim wksOne As Worksheet
Dim wksTwo As Worksheet
Dim wksAct As Worksheet
Dim lRow As Long
Dim lRow2 As Long
Dim lFirstRow As Long
Dim rMy As Range
Dim iCol As Integer
Dim bSwitch As Boolean

'wo fängt die Liste an? Im Beispiel in Zeile 3. HIER anpassen, falls es im Original anders ist.
lFirstRow = 3

'Stehen die Daten in Spalte A? Hier ändern. (Spalte A = 1, B = 2 usw)
iCol = 1

'in deiner Originaltabelle werden die ja nicht "Tabelle1" und 2 heissen? Hier umbenennen!
Set wksSource = Sheets("Tabelle1")
Set wksOne = Sheets("Tabelle2")
Set wksTwo = Sheets("Tabelle3")

bSwitch = False

With wksSource
    lRow = .Cells(Rows.Count, iCol).End(xlUp).Row               'letzte Zeile
    For Each rMy In .Range(.Cells(lFirstRow, iCol), .Cells(lRow, iCol))
        bSwitch = Not bSwitch                                   'abwechselnd
        If bSwitch Then                                         'das eine oder das andere Blatt
            Set wksAct = wksOne
        Else
            Set wksAct = wksTwo
        End If
        lRow2 = wksAct.Cells(Rows.Count, 1).End(xlUp).Row + 1   'letzte Zeile
        rMy.Copy                                                'kopieren
        wksAct.Range("A" & lRow2).PasteSpecial xlPasteValues    'einfügen
    Next rMy
End With

'Text-In-Spalten ausgelagert in eigenes Sub!
Call MakeTextToCol(wksOne)  'Text in Spalten die erste
Call MakeTextToCol(wksTwo)  'Text in Spalten die zweite

End Sub

Sub MakeTextToCol(wksMySheet As Worksheet)
Dim lRow As Long
Dim fRow As Long
With wksMySheet
    fRow = .Range("A1").End(xlDown).Row + 1         'erste Zeile (wenns so ist wie es im  _
Beispiel ist! Keine Überschrift in A1?
    'fRow = 5                                       'notfalls hier die erste Zeile fix setzen,  _
die Zeile drüber dann auskommentieren
    lRow = .Cells(Rows.Count, 1).End(xlUp).Row      'letzte Zeile
    .Range("A" & fRow & ":A" & lRow).TextToColumns Destination:=Range("A4"), DataType:= _
xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:= _
        True            'Text in Spalten ausführen
End With
End Sub
Grüße,
Klaus M.vdT.


  

Betrifft: AW: Jede 2 Zeile in neues Register kopieren von: Arthur
Geschrieben am: 19.11.2012 14:53:56

oh super, es funktioniert auch bei mir!
Vielen Dank auch für die tollen Erklärungen in grüner Schrift, sonst hätte ich es nicht verstanden.
Top!

Viele Grüsse

Arthur


  

Betrifft: Danke für die Rückmeldung! o.w.T. von: Klaus M.vdT.
Geschrieben am: 19.11.2012 15:30:19

.


 

Beiträge aus den Excel-Beispielen zum Thema "Jede 2 Zeile in neues Register kopieren"