AW: Jede 2 Zeile in neues Register kopieren
19.11.2012 14:33:05
Klaus
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.