Zelle kopieren, abhängig von anderen Zellwert

Hallo zusammen,
ich habe mal wieder eine Frage:
In meinem Sheet1 stehen in der Spalte A Namen, die alle mehrfach (bspw. 5x, also Zellen A1:A5) vorkommen. Zu den Namen stehen jeweils in der Spalte E und F Werte. Zu dem gleichen Namen kann es also bspw. in den E1:E5 und F1:F5 Werte geben.
In meinem Sheet2 soll in der Spalte A jeder Name nur einmal stehen. Das habe ich auch schon hinbekommen.
Die Werte aus den Sheet 1, Spalte E (bspw. E1:E5) und F (bspw. F1:F5) sollen nun ebenfalls in der gleichen Zeile stehen. Also: E1 in Zelle E1, F1 in Zelle F1, E2 in Zelle G1, F2 in Zelle H1 usw.
Das Makro muss dementsprechend so lange die Werte aus Sheet1, Spalte E und F in Sheet2, Spalten ab E kopieren, bis ein neuer Name kommt. Für diesen sollen dann ebenfalls die Werte nebeneinander eingefügt werden (dann Zeile 2).
Ich stehe hier grad noch etwas auf dem Schlauch, wie man hier am besten vorgehen kann. Ggf. über Schleifen?
Vielleicht kann ja einer helfen, ich wäre sehr dankbar!! :-)
Liebe Grüße

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Xenia,
Der Code schreibt erst die Namen ins Tabellenblatt 2, dann kopiert er die Werte in Spalte 5 und 6.
probier mal:

Sub Xenia()
Dim S1 As Worksheet
Dim S2 As Worksheet
Set S1 = ThisWorkbook.Sheets(1)
Set S2 = ThisWorkbook.Sheets(2)
Dim rng1 As Range
LetzteZeileS1 = S1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To LetzteZeileS1
strSearch = S1.Cells(i, 1)
LetzteZeileS2 = S2.Cells(Rows.Count, 1).End(xlUp).Row
Err.Number = 0
bFailed = False
On Error Resume Next
strOut = Application.WorksheetFunction.Match(strSearch, S2.Range("A:A"), 0)
If Err.Number  0 Then bFailed = True
On Error GoTo 0
If Not bFailed Then
DoNothing = True
Else
S2.Cells(LetzteZeileS2 + 1, 1) = strSearch
End If
Next i
For i = 1 To LetzteZeileS1
strSearch = S1.Cells(i, 1)
LetzteZeileS2 = S2.Cells(Rows.Count, 1).End(xlUp).Row
Err.Number = 0
bFailed = False
strOut = ""
On Error Resume Next
strOut = Application.WorksheetFunction.Match(strSearch, S2.Range("A:A"), 0)
If Err.Number  0 Then bFailed = True
On Error GoTo 0
If strOut = "" Then
DoNothing = True
Else
LetzteSpalte = S2.Cells(strOut, 256).End(xlToLeft).Column
If LetzteSpalte = 1 Then LetzteSpalte = 4
S2.Cells(strOut, LetzteSpalte + 1) = S1.Cells(i, 5)
S2.Cells(strOut, LetzteSpalte + 2) = S1.Cells(i, 6)
End If
Next i
End Sub

Beliebteste Forumthreads (12 Monate)

Zelle kopieren, abhängig von anderen Zellwert

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

308 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zelle kopieren, abhängig von anderen Zellwert

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

308 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread