Sub RefreshAll()
Dim dblTimeAdd '
dblTimeAdd = TimeValue("02:00") 'прибавление времени
Dim llastr As Long, arr, x
Dim arr2, xx
Dim rr As Range, lс As Long
Dim asSp, s As String, s1 As String, s2 As String
Dim wsStat As Worksheet

'----------------------------------
'сверка на совпадение идентификатора
'----------------------------------

Set wsStat = Sheet1
With Sheet2 'Aux
llastr = .Cells(.Rows.Count, 2).End(xlUp).Row
If llastr < 4 Then Exit Sub

CheckDate
arr = .Cells(4, 2).Resize(llastr - 3, 1)
If Not IsArray(arr) Then
ReDim arr(1 To 1, 1 To 1)
arr(1, 1) = .Cells(4, 2)
End If
End With

Application.ScreenUpdating = 0
'Stats
With shRes '
llastr = .Cells(.Rows.Count, 1).End(xlUp).Row
If llastr >= 2 Then
.Cells(2, 1).Resize(llastr - 1, 1).EntireRow.Value = Empty
End If
End With
llastr = 1
Sheet1.Activate
For Each x In arr
wsStat.Range("B3").Value = x
Call Sheet1.refresh_select
'дополняем лист "Должно так выходить"
Set rr = wsStat.Range("U35:X49")
For lr = 1 To rr.Rows.Count
s = rr.Cells(lr, 2).Value
If s <> "" Then
asSp = Split(s, " - ", 2)
If UBound(asSp) > 0 Then
arr2 = wsStat.Range("Q6:Q36").Value
s1 = LCase(Trim(asSp(0)))
s2 = LCase(Trim(asSp(1)))
For Each xx In arr2
If LCase(Trim(xx)) = s1 Then
wsStat.Range("C7").Value = xx
End If
If LCase(Trim(xx)) = s2 Then
wsStat.Range("D7").Value = xx
End If