makro: jede zweite zeile kopieren will nich

Forumthread: makro: jede zweite zeile kopieren will nich

23.11.2007 19:58:32

Hans

hallo,
ich möchte nur jede 2 Zeile aus einer Spalte in eine andere Spalte auf ein anderes Tabellenblatt kopieren.
Wie stell ich das den an? mein Versuch klappt nicht.
Bsp. Tabellenblatt 1 hat in Spalte B sehr viele Zeilen, jetzt will ich aber nur jede 2 Zeile kopieren. Zeilen 2,4,6,8,10 usw. nach Tabellenblatt 2 Spalte B in die Zeile 1,2,3,4,5 also fortlaufend.
lngSpalte = 2
lngLetzteZeile = wksQuelle.Cells(wksQuelle.Rows.Count, lngSpalte).End(xlUp).Row
If lngLetzteZeile > 11 Then
For lngZeile = lngLetzteZeile To 2 Step -1
wksQuelle.Range(wksQuelle.Cells(12, lngSpalte), wksQuelle.Cells(lngLetzteZeile, lngSpalte)).Copy
wksZiel.Cells(2, lngSpalte).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Next
End If

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: makro: jede zweite zeile kopieren will nich

23.11.2007 20:01:00

Hajo_Zi

Hallo Hans,
warum machst Du die Schleife von hinten nach vorne?
Wenn jede zweite Zeile dann Step -2
Der Code , Operation:=xlNone, SkipBlanks:=False, Transpose:=False ist sinnlos da Standard.

AW: makro: jede zweite zeile kopieren will nich

23.11.2007 20:09:00

Uduuh

Hallo,
Schema:


for i=2 to lngLetzteZeile Step 2
Sheets(2).cells(i/2;2)=sheets(1).cells(i,2)
next i

Gruß ausm Pott
Udo

AW: makro: jede zweite zeile kopieren will nich

24.11.2007 04:55:00

Daniel

HI
hier 2 Beispiele, wie du sowas lösen kannst
Makro 1 über Autofiler
Makro 2 mit Formeln
beide Methoden sind schleifenfrei und daher sehr schnell und auch für sehr grosse Datenmengen geeignet.


Sub Makro1()
Dim lngLetzteZeile As Long
Dim lngSpalte As Long
Dim wksZiel As Worksheet
Dim wksQuelle As Worksheet
Set wksZiel = Sheets(1)
Set wksQuelle = Sheets(2)
With wksQuelle
lngSpalte = 2
lngLetzteZeile = .Cells(65536, lngSpalte).End(xlUp).Row
.Range("A:B").Insert
.Range("A1").Resize(lngLetzteZeile).FormulaR1C1 = "=Row()"
.Range("B1").Resize(lngLetzteZeile).FormulaR1C1 = "=MOD(ROW(),2)"
.Range("A1").Resize(lngLetzteZeile, 2).Formula = Range("A1").Resize(lngLetzteZeile, 2). _
Value
.Range("A1").CurrentRegion.Sort , key1:=.Range("B2"), order1:=xlAscending, header:=xlYes
.Range("A1").AutoFilter field:=2, Criteria1:="=0"
.Columns(lngSpalte + 2).SpecialCells(xlCellTypeVisible).Copy
wksZiel.Cells(1, lngSpalte).PasteSpecial xlPasteValues
.Range("A1").AutoFilter
.Range("A1").CurrentRegion.Sort , key1:=.Range("A2"), order1:=xlAscending, header:=xlYes
.Range("A:B").Delete
End With
End Sub


Sub Makro2()
Dim lngLetzteZeile As Long
Dim lngSpalte As Long
Dim wksZiel As Worksheet
Dim wksQuelle As Worksheet
Set wksZiel = Sheets(1)
Set wksQuelle = Sheets(2)
lngSpalte = 2
lngLetzteZeile = wksQuelle.Cells(65536, lngSpalte).End(xlUp).Row
With wksZiel.Cells(2, lngSpalte).Resize(lngLetzteZeile / 2, 1)
.FormulaR1C1 = "=INDEX('" & wksQuelle.Name & "'!C,ROW()*2-2)"
.Formula = .Value
End With
End Sub

Gruß, Daniel

AW: makro: jede zweite zeile kopieren will nich

25.11.2007 16:30:24

Hans

hi,
danke klappt.
noch eine frage.
kann man das so erweitern das man das nur machen kann wenn die werte in spalte xy ein bestimmtes muster haben, falls nicht abbruch und eine rückmeldung (also msgbox)?
in meinen fall 4ziffern gefolgt von einen leerzeichen!
xxxx xxxx xxxx
kann excel sowas?
grüsse
hans

AW: makro: jede zweite zeile kopieren will nich

25.11.2007 17:07:38

Daniel

Hi
kann man:


Sub Test()
Dim rngBereich As Range
Dim arrBereich
Dim a As String
Dim i As Long
Dim xy As Integer
xy = 1 'hier deine SpaltenNr. eintragen
With ActiveSheet
arrBereich = .Range(.Cells(2, xy), .Cells(65536, xy).End(xlUp))
End With
For i = 1 To UBound(arrBereich, 1)
a = arrBereich(i, 1)
If Len(a)  14 Then Exit For
If Mid(a, 5, 1)  " " Then Exit For
If Mid(a, 10, 1)  " " Then Exit For
If Not IsNumeric(Replace(a, " ", "")) Then Exit For
Next
If i

Gruß, Daniel

AW: makro: jede zweite zeile kopieren will nich

27.11.2007 20:06:00

Hans

hi,
hab noch ein problem. leider
ich musste das script noch erweitern.
und zwar
falls eine zelle leer ist, dann soll er in einer andere spalte dafür diesen wert suchen, falls er da fündig wird, weiter in der schleife. das klappt.
ABER:
gibts nun die möglichkeit falls das script nun "ausweichen" musste dann einen spezifischen wert bsp. 22.11 in das ziel tabellenblatt in einer anderen spalte zu schreiben, aber in der selben zeile wie der wert der aus den array in das ziel tabellenblatt geschrieben wird?
Mein Problem ist die selbe Zeile zu diesen "ausweich" Werten anzusprechen
"
Next
wksZiel.Cells(2, lngSpalte).Resize(UBound(arr) + 1, 1) = WorksheetFunction.Transpose(arr)
Erase arr
"
hier müsste das mit rein aber weiss nich wie.


Sub blabla()
Dim wksQuelle As Worksheet, wksZiel As Worksheet
Dim lngSpalte As Long, lngLetzteZeile As Long, lngSchleife As Long, i As Long
Set wksQuelle = Worksheets("T1")
Set wksZiel = Worksheets("T2")
Dim arr()
'die Länge der Liste ermitteln
lngLetzteZeile = wksQuelle.Cells.SpecialCells(xlCellTypeLastCell).Row
'von Spalte B der Tabelle T1 nach Spalte X der Tabelle T2 jeden 2.Wert
ReDim arr(lngLetzteZeile / 2)
lngSpalte = 24
For lngSchleife = 1 To lngLetzteZeile Step 2
arr(i) = wksQuelle.Cells(lngSchleife, 2)
'''NEU'''''
If wksQuelle.Cells(lngschleife, lngSpalte1) = "" Then
lngSpalte1 = 6 'F
If wksQuelle.Cells(lngschleife, lngSpalte1) = "" Then
lngSpalte1 = 8 'H
If wksQuelle.Cells(lngschleife, lngSpalte1) = "" Then
lngSpalte1 = 9 'I
End If
End If
End If
i = i + 1
Next
wksZiel.Cells(2, lngSpalte).Resize(UBound(arr) + 1, 1) = WorksheetFunction.Transpose(arr)
Erase arr
'MsgBox "Fertig!!!", 64
End Sub

Beliebteste Forumthreads (12 Monate)

makro: jede zweite zeile kopieren will nich

Forumthread: makro: jede zweite zeile kopieren will nich

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

makro: jede zweite zeile kopieren will nich

Forumthread: makro: jede zweite zeile kopieren will nich

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

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread