Hallo Zusammen,

ich habe folgendes Problem:

Habe eine Tabelle und in Spalte A stehen Artikelnummern, diese können häufiger vorkommen, in Spalte C stehen verschiedene Nummern die dazugehören.

Nun möchte ich gerne alle Nummern aus Spalte C die zu der gleichen Artikelnummer in Spalte A gehören verketten und mit Semikolon trennen und gerne in Spalte F schreiben lassen. Siehe folgendes Bild:

Ich habe bereits einen Code programmiert, da es noch einige Sachen zu beachten gibt, dieser läuft auch durch, aber es tut sich leider nichts, bräuchte daher Hilfe bei dem oben geschilderten Grundproblem.

Hier trotzdem mein Code nochmal:

Sub Filter1()
'
' Filter1 Makro
'

'
Application.ScreenUpdating = False

Application.EnableEvents = False

    Sheets("Tabelle1").Select

    Dim J As Long
    Dim jmax As Long
    jmax = Range("A2").End(xlDown).Row
   
    For J = 2 To jmax
        On Error Resume Next

    ActiveSheet.Range("$A$1:$E$51336").AutoFilter Field:=1, Criteria1:= _
        "J" 
    Cells.Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Zwischenspeicher").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Sheets("Zwischenspeicher").Select

    ActiveSheet.Range("$A$1:$E$200").AutoFilter Field:=5, Criteria1:= _
        "#NV"

    Cells.Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Zwischenspeicher2").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Sheets("Zwischenspeicher2").Select
    Range("C2:C200").Select
    Selection.Copy
    Range("F3").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True

    Range("F2").Select
    ActiveCell.FormulaR1C1 = _
        "=R[1]C&"";""&R[1]C[1]&"";""&R[1]C[2]&"";""&R[1]C[3]&"";""&R[1]C[4]&"";""&R[1]C[5]&"";""&R[1]C[6]"

    Range("F2").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Sheets("Endstand").Select

    Range("D2").Select
    Cells(J, 4) = WorksheetFunction.VLookup(Cells(J, 1), Sheets("Zwischenspeicher2").Range("A:F"), 6, False)
    Cells(J, 4).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

    Sheets("Zwischenspeicher").Select
    Cells.Select
    Selection.Delete Shift:=xlUp

    Sheets("Zwischenspeicher2").Select
    Cells.Select
    Selection.Delete Shift:=xlUp

    Sheets("Tabelle1").Select
    ActiveSheet.ShowAllData

    Next J
    
Application.CutCopyMode = False
 
Application.ScreenUpdating = True

Application.EnableEvents = True


End Sub

Ich hoffe ihr könnt mir helfen, vielen Dank schon mal! :)

Liebe Grüße

Sarah