Excel alle Versionsnummern eines Teils in einer Zeile aufzählen

Sub AbgerundetesRechteck1_Klicken()
    Dim strWert As String
    Dim strVergleichsWert As String
    Dim counter As Integer
    Dim letzterWert As Integer
    
    strVergleichsWert = Range("A" & 2)
    strWert = ""
    counter = 0
    letzterWert = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
    For i = 2 To letzterWert + 1
GoBack:
        With Sheets(1)
            If .Range("A" & i) = strVergleichsWert Then
                strWert = strWert & .Range("C" & i) & " " & .Range("B" & i) & "; "
                counter = counter + 1
            Else
                strVergleichsWert = .Range("A" & i)
                .Range("D" & i - counter & ":D" & i - 1).Value = Left(strWert, Len(strWert) - 2)
                strWert = ""
                counter = 0
                GoTo GoBack
            End If
        End With
    Next i
    
End Sub

Option Explicit

Sub AbgerundetesRechteck1_Klicken()
Dim db As MakeItADatabase
Set db = New MakeItADatabase

Dim x As Long 'row counter
x = 1 'ignore header

db.SetSheet = ThisWorkbook.Sheets.Item(1)

With ThisWorkbook.Sheets.Item(1)
    Do
        x = x + 1
        .Cells(x, 4).Value = db.GetAllVersions(.Cells(x, 1), CInt(.Cells(x, 2)))
    Loop Until .Cells(x, 1) = ""
End With

Set db = Nothing
End Sub

Option Explicit

Private cN As Object
Private rs As Object
Private strTable As String

Private Sub Class_Initialize()
Set cN = CreateObject("ADODB.Connection")
cN = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
               "Data Source= " & ThisWorkbook.FullName & ";" & _
               "Extended Properties=""Excel 12.0; HDR=Yes;"""
cN.Open
End Sub

Public Property Let SetSheet(ByVal sh As Worksheet)
    strTable = sh.Name
End Property

Public Property Get SetSheet() As Worksheet
    Set SetSheet = ThisWorkbook.Sheets(strTable)
End Property

Public Function GetAllVersions(ByVal refTeil As String, ByVal vers As Integer) As String
Dim strTemp As String

'Version excluded
'GetRecordset "SELECT * FROM [" & strTable & "$] WHERE Part LIKE '" & refTeil & "' AND NOT Version = " & vers & " ORDER BY Version asc;"

'Version included
GetRecordset "SELECT * FROM [" & strTable & "$] WHERE Part LIKE '" & refTeil & "' ORDER BY Version asc;"

Do Until rs.EOF
    If Len(strTemp) > 0 Then strTemp = strTemp & "; "
    strTemp = strTemp & rs.Fields(2).Value & " " & rs.Fields(1).Value
    rs.movenext
Loop

GetAllVersions = strTemp

strTemp = ""
Set rs = Nothing
End Function

Private Sub GetRecordset(ByVal sql As String)
Set rs = CreateObject("ADODB.recordset")
rs.Open sql, cN, 2, 1
End Sub

Private Sub Class_Terminate()
cN.Close
End Sub

Sub AbgerundetesRechteck1_Klicken()
Dim db As MakeItADatabase
Dim strResult As String
Dim intRowsOnSemicolon As Integer
Set db = New MakeItADatabase
 
Dim x As Long 'row counter
x = 1 'ignore header
 
db.SetSheet = ThisWorkbook.Sheets.Item(1)
With ThisWorkbook.Sheets.Item(1)
    Do
        x = x + 1
        If .Cells(x, 1) = "" Then Exit Sub
        strResult = db.GetAllVersions(.Cells(x, 1), .Cells(x, 2))
        intRowsOnSemicolon = UBound(Split(strResult, ";"))
        
        .Range("D" & x & ":D" & x + intRowsOnSemicolon) = Left(strResult, Len(strResult) - 2)
        x = x + intRowsOnSemicolon
        strResult = ""
    Loop Until x = 0
End With

Set db = Nothing
End Sub