Копирование данных из нескольких таблиц в одну

Sub Выборка()
Dim Lr, R, Ld
Dim SH As Worksheet
Dim Si As Worksheet
Set Si = Worksheets("итоговая таблица")
Si.Rows("4:50000").ClearContents
Si.Rows("4:50000").Font.Bold = False
    For Each SH In ActiveWorkbook.Worksheets
   ' Debug.Print SH.Name
        If SH.Name <> "итоговая таблица" Then
            With SH
            Lr = .Cells(Rows.Count, 1).End(xlUp).Row
            Ld = Si.Cells(Rows.Count, 1).End(xlUp).Row + 2
                Si.Cells(Ld, 1) = SH.Name
                Si.Cells(Ld, 1).Font.Bold = True
                For R = 5 To Lr
                Ld = Ld + 1
                Si.Cells(Ld, 1).Value = .Cells(R, 1).Value
                Si.Cells(Ld, 6).Value = .Cells(R, 2).Value
                Si.Cells(Ld, 7).Value = .Cells(R, 22).Value
                Next R
            End With
        End If
    Next
    MsgBox "Ok", 64, ""
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)