Sub Find_to_index(list As String, index As String, val1 As String, N_horz_val1 As Integer, N_vert_val1 As Integer)
Rem зная имя листа, индекс обьекта и содержимое переменной находим обьект в его координатах
Rem возвращаем номер столбца и номер строки, содержащие обьект

Dim iRow As Integer
Dim iClm As Integer
Dim i As Integer

Узнаем номер последней строки листа
iRow = Sheets(list).UsedRange.Row + Sheets(list).UsedRange.Rows.Count -  1 
Узнаем номер последней колонки листа
iClm = Sheets(list).UsedRange.Column + Sheets(list).UsedRange.Columns.Count -  1 

rem Индекс - это имя колонки, содержащееся в первой строке.
rem Ищем совпадение  данных в первой строке с образцом
For i =  1  To iClm+ 1 
    If Sheets(list).Cells( 1 , i) = index Then GoTo Lab1 rem Нашли
Next i
Lab1:

N_horz_val1 = i
    
    If N_horz_val1 = iClm+ 1  Then
        MsgBox "На листе " + list + " не обнаружен индекс " + index
        GoTo Lab3
    End If

rem Зная колонку ищем теперь столбец
For i =  1  To iRow +  1 
    If Sheets(list).Cells(i, N_horz_val1) = val1 Then GoTo Lab2 rem нашли
Next i
Lab2:

N_vert_val1 = i

    If N_vert_val1 = iRow +  1  Then
        MsgBox "Запись " + val1 + " с индексом " + index + " не найдена на листе " + list
        GoTo Lab3
    End If

Lab3:
    

End Sub

rem Зная колонку ищем теперь строку

With Sheets(list)
Rem Количество колонок на листе +1
    iClm = .UsedRange.Column + .UsedRange.Columns.Count
End With
    
Rem В области от первой колонки до последней и в первой строке 
With Worksheets(list).Range(Sheets(list).Cells( 1 ,  1 ), Sheets(list).Cells( 1 , iClm -  1 ))
Rem Ищем  содержимое переменной index и узнаем адрес ячейки
    Set C = .Find(index, LookIn:=xlValues)
Rem и узнаем адрес ячейки
    firstAddress = C.Address
End With

Set rColumn = ws.UsedRange.Rows( 1 ).Find(ColumnName).EntireColumn

Set rColumn = ws.UsedRange.Rows( 1 ).Find(ColumnName).EntireColumn

iRow = Sheets("Data1").UsedRange.Row + Sheets("Data1").UsedRange.Rows.Count -  1 
For i = j -  1  To  1  Step - 1 
    T1_date = Sheets("Data_F").Cells( 1 , i)
'    Находим требуемую дату на листе "Data1"
    L = "Data1"
    CLM_1 = FindColumn(L, CStr(T1_date))
        
        If CLM_1 <>  0  Then
                Set ws = ActiveWorkbook.Worksheets(L)
                A1 = " "
                A2 =  2 
                While A1 <> ""
'                   диапазон поиска в столбце
                    Set FC1 = ws.Range(Sheets(L).Cells(A2, CLM_1), Sheets(L).Cells(iRow, CLM_1))
'                    Нашли
                    A1 = FC1.End(xlDown).Value
'                        Если то, что нашли - пустое, тогда это конец
                        If A1 = "" Then GoTo metka_K2:
'                    а в какой строке нашли?
                    A2 = FC1.End(xlDown).Row

'                   диапазон поиска в строке
                    Set FR1 = ws.Range(Sheets(L).Cells(A2,  4 ), Sheets(L).Cells(A2, CLM_1 -  2 ))
metka_K1:
'                    Нашли
                    B1 = FR1.End(xlToRight).Value
'                        если встретился 0 - это ошибка - исправить
                        If B1 = "0" Then
                            FR1.End(xlToLeft).Value = ""
                            GoTo metka_K1:
                        End If
'                        Если то, что нашли - пустое,
'                        или колонка найденного не поменялась, тогда значит нашли 0
                        If B1 = "" Or FR1.End(xlToRight).Column = CLM_1 Then
                            B1 = "0"
                        End If
'                    читаем данные
                    B2 = CInt(Sheets("Data_F").Cells( 2 , i))
'                    вычисляем новые
                    B3 = B2 + CInt(A1) - CInt(B1)
'                    записываем новые
                    Sheets("Data_F").Cells( 2 , i) = CStr(B3)
                Wend
                    
        Else
'        Если даты нет - тогда запоминаем 0
            Sheets("Data_F").Cells( 2 , i) =  0 
        End If
metka_K2:

' ...................
' здесь такая - же обработка других листов с похожей структурой
' ...................

next i

Function ColumnAnaliz_1(ByRef SheetsName As String, ByRef ColumnNumber As Long, _
                        ByRef StartDataRow As Integer, ByRef BlokColumnNumber As Integer) As Integer
                        
Dim A1 As String
Dim A2 As Integer

Dim B1 As String

Dim C1 As Integer

Dim iRow As Long

Dim i As Long

rem Определяем конец листа
iRow = Sheets(SheetsName).UsedRange.Row + Sheets(SheetsName).UsedRange.Rows.Count -  1 
rem стартовая строка
i = StartDataRow
rem накопленная сумма
C1 =  0 
Do
    rem смотрим на ячейку
    A1 = Sheets(SheetsName).Cells(i, ColumnNumber)
    rem если не пустая
    If A1 <> "" Then
        rem включаем строчный анализ
        B1 = RowAnaliz_1(SheetsName, i, ColumnNumber, BlokColumnNumber)
        rem и перескакиваем на следующую строку
        i = i +  1 
    Else
        rem Если пустая ищем первую полную
        A1 = Sheets(SheetsName).Cells(i, ColumnNumber).End(xlDown).Value
         rem если не нашли - конец листа достигнут
          If A1 = "" Then Exit Do
        rem запоминаем номер строки, где нашли
        A2 = Sheets(SheetsName).Cells(i, ColumnNumber).End(xlDown).Row
        rem включаем строчный анализ
        B1 = RowAnaliz_1(SheetsName, CLng(A2), ColumnNumber, BlokColumnNumber)
        rem и перескакиваем на следующую строку
        i = A2 +  1 
    End If
rem Производим накопление суммы
    C1 = C1 + CInt(A1) - CInt(B1)
Loop Until A1 = ""
     Rem выдаем результат
    ColumnAnaliz_1 = C1

End Function

Function RowAnaliz_1(ByRef SheetName As String, ByRef NumberRow As Long, _
                    ByRef StartDataColumn As Long, _
                    ByRef ColumnBlockNumber As Integer) As Integer
    
Dim B1 As String
Dim B2 As Integer
rem значение левого данного
B1 = ""
Do
    rem смотрим на ячейку левее
    B1 = Sheets(SheetName).Cells(NumberRow, StartDataColumn -  1 )
      rem Если пустая ищем первую полную
    If B1 = "" Then
        rem Значение левой ячейки
        B1 = Sheets(SheetName).Cells(NumberRow, StartDataColumn).End(xlToLeft).Value
        rem колонка найденной ячейки
        B2 = Sheets(SheetName).Cells(NumberRow, StartDataColumn).End(xlToLeft).Column
rem        если ничего не найдено или колонка найденной ячейки принадлежит 
rem        диапзону от 1 до ColumnBlockNumber то данные равны 0
        If B1 = "" Or B2 < ColumnBlockNumber Then
            B1 =  0 
        End If
    End If
Loop Until B1 <> ""
rem присваиваем результат
RowAnaliz_1 = B1

End Function