Hallo nochmal

In Tabelle1 habe ich mal dein Beispiel nachgebaut.

In ein Modul das hier

Option Explicit
Sub DBC()
    Dim TB1 As Worksheet, TB2 As Worksheet, LR As Long, LC As Integer

    Dim MeL As String, SyL As String
    Dim Sp As Integer, ArrM, ArrS, Z As Long
    Dim i As Integer, j As Integer
    Dim WF
    
    
    Set TB1 = Sheets("Tabelle1")
    Set TB2 = Sheets("Tabelle2")
    
    Application.ScreenUpdating = False
    
    Set WF = WorksheetFunction
    MeL = InputBox("Beispiel:", "Eingabe Message Line", "BO_Land, Kontinent")
    SyL = InputBox("Beispiel:", "Eingabe Syntax Line", "SG_Stadt, Fluss, Temperatur")
    
    'Werte aufteilen
    ArrM = Split(Mid(MeL, 4), ",")
    ArrS = Split(Mid(SyL, 4), ",")
    
    With TB2
        'kopieren
        .UsedRange.Delete
        TB1.UsedRange.Copy .Cells(1, 1)
        
        LR = .Cells(.Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte
        
        '2 Hilfsspalten einfügen
        .Columns(1).Resize(, 2).Insert
        
        LC = .Cells(1, .Columns.Count).End(xlToLeft).Column 'letzte Spalte einer Zeile
        
        .Sort.SortFields.Clear
        
        'Überprüfen, ob Eingabewerte auch vorhanden sind
        For j = LBound(ArrM) To UBound(ArrM)
            If WF.CountIf(.Rows(1), Trim(ArrM(j))) > 0 Then
                If Sp = 0 Then 'Hauptspalte
                    Sp = WF.Match(Trim(ArrM(j)), .Rows(1), 0)
                    
                    'Sortieren nach erstem Wert
                    .Sort.SortFields.Add2 Key:=.Columns(Sp), SortOn:=xlSortOnValues, _
                        Order:=xlAscending, DataOption:=xlSortNormal
                End If
            Else
                MsgBox "Fehler: " & ArrM(j) & " nicht gefunden"
                .UsedRange.Delete
                Exit Sub
            End If
        Next
        
        'sortieren durchführen
        With .Sort
            .SetRange TB2.UsedRange
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
                              
                
        For i = LR To 2 Step -1 'alle zeilen von unten nach oben durchlaufen
            If .Cells(i - 1, Sp) <> .Cells(i, Sp) Then 'bei Wechsel in Hauptspalte BO Zeile erzeugen
                .Rows(i).Copy
                .Rows(i + 1).Insert xlDown
                .Cells(i + 1, 1) = Z 'Zähler
                .Cells(i + 1, 2) = "BO_"
                .Cells(i, 1) = Z
                .Cells(i, 2) = "SG_"
                Z = Z + 1

                'nicht benötigte Spalten löschen
                For j = LC To 3 Step -1
                    If InStr(MeL, .Cells(1, j)) = 0 Then
                        .Cells(i + 1, j).Delete xlToLeft
                    End If
                    
                    If InStr(SyL, .Cells(1, j)) = 0 Then
                        .Cells(i, j).Delete xlToLeft
                    End If

                Next
            Else
                'Wenn mehrere Zeilen vorhanden sind
                .Cells(i, 1) = Z
                .Cells(i, 2) = "SG_"
                
                For j = LC To 3 Step -1
                    If InStr(SyL, .Cells(1, j)) = 0 Then
                        .Cells(i, j).Delete xlToLeft
                    End If
                Next


            End If
                
            
        Next
        
        'Sortieren nach Zähler und dann nach BO /SG
        .Sort.SortFields.Clear
        
        .Sort.SortFields.Add2 Key:=.Columns(1), SortOn:=xlSortOnValues, _
            Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SortFields.Add2 Key:=.Columns(2), SortOn:=xlSortOnValues, _
            Order:=xlAscending, DataOption:=xlSortNormal
        
        With .Sort
            .SetRange TB2.UsedRange
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        'Zeile1 löschen
        .Rows(1).Delete xlUp
        LR = .Cells(.Rows.Count, "A").End(xlUp).Row 'letzte Zeile der Spalte

        'String per Formel zusammensetzen
        With .Cells(1, 1).Resize(LR, 1)
            .FormulaR1C1 = _
            "=CONCATENATE(RC[1],RC[2],"", "",RC[3],"", "",RC[4],"", "",RC[5],"", ""&RC[6]&"", "",RC[7],"", "",RC[8])"
            
            'Formel in Wert
            .Value = .Value
        End With
        
        'alte Spalten und Hilfsspalte löschen
        .Columns(2).Resize(, LC).Delete
        
        'Blatt wechseln
        .Activate
            
    End With

End Sub

Ergibt dann in Tabelle2 das hier

BO_Ungarn, Europa, , , , , 
SG_Budapest, Donau, 27, , , , 
BO_Spanien, Europa, , , , , 
SG_Barcelona, Tajo, 27, , , , 
SG_Madrid, , 27, , , , 
BO_Kanada, Zentralamerika, , , , , 
SG_Toronto, Fraser River, 19, , , , 
BO_Frankreich, Europa, , , , , 
SG_Paris, Rhône, 20, , , , 
SG_Marseille, Seîne, 20, , , , 
BO_Deutschland, Europa, , , , , 
SG_Stuttgart, Elbe, 20, , , , 
SG_München, Spree, 20, , , , 
SG_Hambur, Isar, 20, , , , 
BO_China, Asien, , , , , 
SG_Peking, Amur, 18, , , , 
BO_Amerika, Zentralamerika, , , , , 
SG_New York, Hudson, 24, , , , 

die , bei Bedarf noch löschen

LG UweD