Excel - Spaltenabschnitte in einzelne Zellen fügen - vba

Hallo zusammen,

zunächst erkläre ich Ihnen den Aufbau meiner Tabelle:

Im Tabellenblatt1:
A1 Servername.............B Serverowner
A2 Servername1............B2
A3 Servername2............B3
A4 Servername3.............B4
A5 ....

Im Tabellenblatt2:
SpalteA........................Spalte B
Servername1...............Owner zu Server1
Servername1´..............Owner zu Server1
Servername1...............Owner zu Server1
Servername1´..............Owner zu Server1
Servername1...............Owner zu Server1
Servername1´..............Owner zu Server1
Servername1...............Owner zu Server1
Servername1´..............Owner zu Server1
LeereZelle...................Leere Zelle
Servername2..............Owner zu Server2
Servername2..............Owner zu Server2
Leere Zelle.................Leere Zelle
Servername3..............Owner zu Server3
Servername3..............Owner zu Server3
Servername3..............Owner zu Server3

Hintergrundwissen:
Jeder Server besitzt verschiedenviele Serverowner!

Frage: Ich hätte gerne per vba, das alle Serverowner aus Tabellenblatt2 vom Servername1 in die Zelle B2 in Tabellenblatt1 eingefügt werden,
genauso mit den Serverownern 2, 3 usw....
Ansatz: Den Job hätte ich mir so vorgestellt, das er sagt: Ich beginne in Tabellenblatt2 kopiere alles in Spalte B bis eine Leere-Zelle kommt & füge dies dann in Zelle B2 in Tabellenblatt1,
dann gehe ich weiter und kopiere von der Leeren-Zelle bis zur nächsten Leeren-Zelle alles in die Zelle B3 in Tabellenblatt1.

Danke für eure Hilfe!!

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 266510

Url: https://administrator.de/forum/excel-spaltenabschnitte-in-einzelne-zellen-fuegen-vba-266510.html

Ausgedruckt am: 09.06.2025 um 18:06 Uhr

4 Kommentare

Neuester Kommentar

Hallo AlexIOT,
genau das gewünschte gabs hier schon mal (inkl. Code)
Excel Zeilen in eine Zeile anzeigen

Gruß jodel

Vielen Dank Jodel32!

Mithilfe der Vorlage aus der Antwort konnte ich meine persönliche Lösung bilden:

Sub MergeDuplicates1()

i = 1
Do While i < 200
Dim ws As Worksheet, rngStart As Range, rngEnd As Range, rngCurrent As Range
' Erstes Tabellenblatt referenzieren
Set ws = Worksheets(3)
'Startzelle der Daten festlegen
Set rngStart = ws.Cells(i, "A")
' Zelllendbereich ermitteln
Set rngEnd = rngStart.End(xlDown).Offset(0, 1)

' Bereich zuerst nach Nummern sortieren
ws.Range(rngStart, rngEnd).Sort ws.Cells(i, "B")

'So lange zusammenfassen bis auf eine Zelle keinen Inhalt hat
Set rngCurrent = rngStart
While rngCurrent.Value <> ""
If rngCurrent.Value = rngCurrent.Offset(1, 0).Value Then
rngCurrent.Offset(0, 1).Value = rngCurrent.Offset(0, 1).Value & ", " & rngCurrent.Offset(1, 1).Text
rngCurrent.Offset(1, 0).EntireRow.Delete
Else
Set rngCurrent = rngCurrent.Offset(1, 0)
rngCurrent.EntireRow.Delete
GoTo Raus
End If
Wend
Raus:
i = i + 1
Loop

End Sub

Hallo AlexIOT, Willkommen auf Administrator.de!
Und hier für deinen Fall mit zwei Sheets noch eine etwas passendere Variante als Ergänzung:

Sub MergeCells()
    Dim ws1 As Worksheet, ws2 As Worksheet, cell As Range, c As Range, rngSearch As Range
    Set ws1 = Sheets(1)
    Set ws2 = Sheets(2)
    Set rngSearch = ws2.Range("A:A")  
    With ws1
        For Each cell In .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row)  
            If cell.Value <> "" Then  
                Set c = rngSearch.Find(cell.Value, LookIn:=xlValues, Lookat:=xlWhole)
                If Not c Is Nothing Then
                    firstAddress = c.Address
                    Do
                        If cell.Offset(0, 1).Value <> "" Then  
                            cell.Offset(0, 1).Value = cell.Offset(0, 1).Value & ", " & c.Offset(0, 1).Value  
                        Else
                            cell.Offset(0, 1).Value = c.Offset(0, 1).Value
                        End If
                        Set c = rngSearch.FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> firstAddress
                End If
            End If
        Next
    End With
End Sub