VBA Bestimmte Zellen untereinander

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Pedro,
teste mal:

Option Explicit

Public Sub Kopieren()

    Dim objCell As Range
    Dim strFirstAddress As String
    Dim lngRow As Long
    Dim vntItem As Variant

    With Worksheets("Tabelle2") 'Anpassen !!!
        lngRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    End With

    For Each vntItem In Array(1, 2, 3, 4, 5) 'Anpassen !!!

        Set objCell = Columns(3).Find(What:=vntItem, After:=Cells(Rows.Count, 3), LookIn:=xlValues, LookAt:=xlWhole)

        If Not objCell Is Nothing Then

            strFirstAddress = objCell.Address

            Do

                lngRow = lngRow + 1

                Call objCell.Offset(0, 1).Copy(Destination:=Worksheets("Tabelle2").Cells(lngRow, 1)) 'Anpassen !!!

                Set objCell = Columns(3).FindNext(After:=objCell)

            Loop Until objCell.Address = strFirstAddress

            Set objCell = Nothing

        End If
    Next
End Sub

Gruß
Nepumuk

Hallo Pedro,
das Makro muss aus der Datentabelle gestartet werden, nicht aus der Zieltabelle.

Option Explicit

Public Sub Kopieren()

    Dim objCell As Range
    Dim strFirstAddress As String
    Dim lngRow As Long, lngColumn As Long
    Dim vntItem As Variant

    lngColumn = 1

    For Each vntItem In Array(1, 2, 3, 4, 5) 'Anpassen !!!

        With Worksheets("Tabelle2") 'Anpassen !!!
            lngRow = .Cells(.Rows.Count, lngColumn).End(xlUp).Row
        End With

        Set objCell = Columns(3).Find(What:=vntItem, After:=Cells(Rows.Count, 3), _
            LookIn:=xlValues, LookAt:=xlWhole)

        If Not objCell Is Nothing Then

            strFirstAddress = objCell.Address

            Do

                lngRow = lngRow + 1

                Call objCell.Offset(0, 1).Copy(Destination:= _
                    Worksheets("Tabelle2").Cells(lngRow, lngColumn)) 'Anpassen !!!

                Set objCell = Columns(3).FindNext(After:=objCell)

            Loop Until objCell.Address = strFirstAddress

            Set objCell = Nothing

        End If

        lngColumn = lngColumn + 2

    Next
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

Arbeitsblatt mit dem Namen 'Tabelle2'
	A
1
2	123
3	133
4	143
5	153
6	163
7	173
8	124
9	134
10	144
11	154
12	164
13	174
14	125
15	135
16	145
17	155
18	165
19	175
20	126
21	136
22	146
23	156
24	166
25	176
26	127
27	137
28	147
29	157
30	167
31	177

VBA Bestimmte Zellen untereinander

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

307 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA Bestimmte Zellen untereinander

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

307 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread