Weihnachtsgeschenk

Hallo zusammen,
ich mache gerade die ersten Schritte mit VBA.
Ich habe leider kein gutes Nachschlagewerk um mir die Grundkenntnisse anzueigenen, da ich gerade ein Praktikum in den USA absolviere.
Ich habe eine grosse Tabelle aus der ich bestimmte Zellen in eine andere kopieren moechte. Die Tabelle wird aus SAP gezogen und hat somit immer den gleichen Aufbau.
Das Makro soll Spalte Q durchlaufen und immer wenn "to 0" auftaucht, soll es von dieser Zelle ausgehend, eine nach rechts und zwei nach unten ruecken. Diesen Wert dann kopieren und in ein anderes sheet (Tabelle2)einfuegen. Dieser Vorgang soll solange durchlaufen werden, bis alle "to 0" abgearbeitet wurden und somit alle zu dieser Zelle bezogenen Werte in der Tabelle2 aufgelistet wurden.
Ich hab da mal wild was zusammengeschrieben, aber bis das funktioniert ist Weihnachten. Ich hoffe jemand kann mir helfen! Sozusagen als verfruehtes Weihnachtsgeschenk!


Sub Auswertung()
Dim l As Integer
Dim i As Integer
Sheets("Tabelle1").Activate
Range("Q:Q").Select
Range("Q65536").End(xlUp).Offset(1, 0).Select
l = Selection.Count
For i = 1 To l
If ActiveCell.Value = "to" Then
ActiveCell.Offset(2, 1).Activate
Selection.Copy
Sheets("Tabelle2").Activate
Range("C1").Select
Selection.PasteSpecial Paste:=xlValues
ActiveCell.Offset(1, 0).Select
Next
End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub VorWeihnachten() Dim rng As Range, i As Long i = 1 For Each rng In Sheets("Tabelle1").Range("Q:Q") If rng Like "to 0" Then Sheets("Tabelle2").Range("C" & i) = rng.Offset(2, 1) i = i + 1 End If Next End Sub

Sub Auswertung() Dim wksQ As Worksheet 'Quelle Dim wksZ As Worksheet 'Ziel Dim rng As Range Dim sFirst As String Dim lRow As Long Set wksQ = Sheets("Tabelle1") Set wksZ = Sheets("Tabelle2") lRow = 1 Set rng = wksQ.Range("Q:Q").Find(What:="to", LookIn:=xlValues, _ LookAt:=xlWhole, After:=wksQ.Range("Q65536")) If Not rng Is Nothing Then sFirst = rng.Address rng.Offset(2, 1).Copy wksZ.Cells(lRow, 3) lRow = lRow + 1 Do Set rng = wksQ.Range("Q:Q").FindNext(After:=rng) If rng.Address = sFirst Then Exit Do rng.Offset(2, 1).Copy wksZ.Cells(lRow, 3) lRow = lRow + 1 Loop End If End Sub

Sub VorWeihnachten() Dim rng As Range, i As Long i = 1 For Each rng In Sheets("Tabelle1").Range("Q:Q") If rng Like "To 0" Then ActiveCell.Offset(2, 1).Select Selection.Copy Sheets("Tabelle2").Activate Range("C1").Select Selection.PasteSpecial Paste:=xlValues Application.CutCopyMode = False Sheets("Tabelle2").Range("C" & i) = rng.Offset(2, 1) i = i + 1 End If Next End Sub

Beliebteste Forumthreads (12 Monate)

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

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread