Sub fillTable()
    Dim shSVOD As Worksheet, shTemp As Worksheet
    Dim arrShopNames As Variant, vShopName As Variant
    Dim lRow As Long
    Dim Rng As Range
    
    Set shSVOD = Worksheets("Сводная")
    
    With shSVOD
        'список всех магазинов из столбца В
        arrShopNames = .Range("B2:B" & .Cells(.Rows.Count, 2).End(xlUp).Row).Value '2 это столбец В
    End With
    
    'отключаем обновление экрана
    Application.ScreenUpdating = False
    
    'переменная для подсчёта строк (в какую строку будем вставлять данные)
    lRow = 1
    
    'цикл по всем магазинам из столбца В
    For Each vShopName In arrShopNames
        lRow = lRow + 1 'на листе Сводная 1-й магазин находится на 2-й строке и далее +1
        'присваиваем shTemp очередному листу по названию магазина
        On Error Resume Next
        Set shTemp = Worksheets(vShopName)
        On Error GoTo 0
        'если лист называется так как и магазин, то shTemp будет лист, если Nothing, значит лист назван не так как магазин
        If Not shTemp Is Nothing Then
            With shTemp
                'присваиваем диапазон переменной Rng
                Set Rng = .Range("B1:B" & .Cells(.Rows.Count, 2).End(xlUp).Row) '2 это столбец В
            End With
            'копируем диапазон В из очередного листа
            Rng.Copy
            'вставляем на лист Сводная и транспонируем его
            shSVOD.Cells(lRow, 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        End If
    Next vShopName
    
    'убираем выделение строки, перемещая курсор в ячейку А1
    shSVOD.Range("A1").Select
    
    'включаем обновление экрана
    Application.ScreenUpdating = True
    
    MsgBox "Копирование данных завершено!", vbInformation, "Конец"
End Sub

Sub fillTable()
    Dim ws As Worksheet, shTemp As Worksheet
    Dim i As Long, LastRow As Long
    Dim sheetName As String
    Dim Rng As Range

    Set ws = Worksheets("Сводная") 'тут надо обращаться к листу Сводная, а не ко всему файлу
    With ws
        LastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
        For i = 2 To LastRow
            sheetName = ws.Cells(i, 2)
            On Error Resume Next
            Set shTemp = Worksheets(sheetName)
            On Error GoTo 0
            If Not shTemp Is Nothing Then
                With shTemp
                    Set Rng = .Range("B1:B" & .Cells(.Rows.Count, 2).End(xlUp).Row)
                    Rng.Copy
                End With
                .Cells(i, 3).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
            End If
        Next i
    End With
End Sub