Private Sub CommandButton1_Click()
Dim myConnect As String, mySQL As String, myRecord As Object, QT As QueryTable
Dim wshTarget As Worksheet, conn
With ActiveWorkbook
        myConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
           "Data Source=" & .FullName & ";" & _
           "Extended Properties=""Excel 12.0;HDR=YES"""
    Set myRecord = CreateObject("ADODB.Recordset")
With Worksheets("Управление")
    If .Cells(2, 2) = "" And .Cells(2, 3) = "" Then
        mySQL = "SELECT * FROM [Исходные$]"
    ElseIf .Cells(2, 2) = "" Or .Cells(2, 3) = "" Then
        MsgBox "Заполните все критерии отбора!!!!", vbCritical: Set myRecord = Nothing: Exit Sub
    Else
        mySQL = "SELECT SKU, ID, NAME, QTY, PRICE FROM [Исходные$] WHERE " & .Cells(2, 2) & "='" & .Cells(2, 3) & "'"
    End If
On Error GoTo Errorh
    myRecord.Open mySQL, myConnect
End With
    Set wshTarget = .Worksheets("Result")
With wshTarget
    .Cells.Clear
    Set QT = .QueryTables.Add(myRecord, .Range("A1"))
    QT.Refresh
End With
    Set QT = Nothing
    myRecord.Close
    Set myRecord = Nothing
For Each conn In .Connections
    conn.Delete
Next conn
For Each conn In Worksheets("Result").QueryTables
    conn.Delete
Next conn
End With
Exit Sub
Errorh:
    MsgBox "Проверьте корректность написания условия отбора!!!", vbCritical
    Set myRecord = Nothing
End Sub

Sub Разбить_ID()
    Dim LO As ListObject, i As Long, n As Long, SKU As String, ID As String

    Application.ScreenUpdating = False
    Application.Calculation = xlManual
    Set LO = ActiveSheet.ListObjects(1)
    With LO
        For i = .DataBodyRange.Rows.Count + 1 To 1 Step -1
            If InStr(1, .Range.Cells(i, 2), ",", vbTextCompare) > 0 Then
                SKU = .Range.Cells(i, 1)
                ID = .Range.Cells(i, 2)
                .Range.Cells(i, 1) = SKU & "-" & Split(ID, ",")(0) 'SKU
                .Range.Cells(i, 2) = Split(ID, ",")(0) 'ID
                For n = 1 To UBound(Split(ID, ","))
                    .ListRows.Add (i + n - 1)
                    .ListRows(i - 1).Range.Copy .ListRows(i + n - 1).Range
                    .Range.Cells(i + n, 1) = SKU & "-" & Split(ID, ",")(n) 'SKU
                    .Range.Cells(i + n, 2) = Split(ID, ",")(n) 'ID
                Next n
            End If
        Next i
    End With
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = True
    MsgBox "Конец", vbInformation, ""
End Sub