Sub qwe()
Application.ScreenUpdating = False
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim i As Integer, lr As Integer, w As String


Set ws1 = ThisWorkbook.Worksheets("ТТ")
Set ws2 = ThisWorkbook.Worksheets("МСК")
Set ws3 = ThisWorkbook.Worksheets("Back")


w = Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") - 1)
    
    Workbooks.Add (1)
        With ActiveWorkbook
            .SaveAs Filename:=ThisWorkbook.Path & "\МСК " & w & ".xls"
            '.Close True
        End With

lr = ws1.Cells(Rows.Count, 4).End(xlUp).Row
With ws2
For i = 9 To lr
    If ws1.Cells(i, 2) <> "" Then
    ws2.Copy , Worksheets(Worksheets.Count)
    wsC = Sheets.Count
    Sheets(wsC).Name = ws1.Cells(i, 2)
    Sheets(wsC).Cells(6, 43) = ws1.Cells(2, 16)
    Sheets(wsC).Cells(6, 1) = ws1.Cells(i, 6)
    Sheets(wsC).Cells(10, 1) = ws1.Cells(i, 14)
    Sheets(wsC).Cells(6, 23) = ws1.Cells(4, 16)
    
      
    End If
Next i

End With
Application.ScreenUpdating = True
End Sub