Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
928to932
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
928to932
928to932
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

makro: jede zweite zeile kopieren will nich

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

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

Betreff
Datum
Anwender
Anzeige
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ß aus’m 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

Anzeige
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

Anzeige
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


Anzeige

313 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige