Set total_with_dev = sheet.UsedRange.Find(What:="Итого с оборудованием", LookIn:=xlValues, LookAt:=xlPart).Offset(0, 1)
Set total = sheet.UsedRange.Find(What:="ВСЕГО по смете", LookIn:=xlValues, LookAt:=xlPart).Offset(0, 1)

declare @div int, @period int
set @div = null
select   @period = 202001

SELECT EMR.LINK, EMR.D_Date, FC.LINK F_Charges, fcd.F_Registr_Pts
INTO #EMR1
   FROM ee.FD_Paysheets FC
   INNER JOIN ee.FVT_Paysheets_Details FCD
      ON  FC.LINK = FCD.F_Paysheets
      AND FC.N_Period = @PERIOD
   INNER JOIN SD_Divisions SD
      ON  SD.LINK = FC.F_Division
      AND (SD.LINK = 5 OR SD.F_Division = 5)
      AND (fc.F_Division = @div or @div is null)
   INNER JOIN ED_Meter_Readings EMR
      ON  EMR.LINK = FCD.F_Meter_Readings

Sub arrange_in_folders()
    Dim File, Path, FileContent, region As String
    Dim objFileSys As Object
    Dim i, j As Integer
    
    'выбираем папку с файлами-источниками информации
    With Application.FileDialog(msoFileDialogFolderPicker)
        .ButtonName = "OK"
        .Title = "Выберите папку, содержащую файлы"
        If .Show = 0 Then
            Exit Sub
        End If
        Path = .SelectedItems(1)
    End With
    
    File = Dir(PathName:=Path + "\*.xml")
    
    Set objFileSys = CreateObject("Scripting.FileSystemObject")
    
    Do Until File = "" 'пока не закончатся файлы
        FileContent = objFileSys.OpenTextFile(Path + "\" + File).ReadAll
        i = InStr(1, FileContent, "<RegionId>")
        j = InStr(1, FileContent, "</RegionId>")
        If InStr(1, FileContent, "<RegionId>") Then
            region = Mid(FileContent, i + 10, j - i - 10)
            If Dir(Path + "\" + region, vbDirectory) = "" Then MkDir Path + "\" + region
        End If
        File = Dir
    Loop

    Set File = Nothing
    Set Path = Nothing
    Set FileContent = Nothing
End Sub

Dim Node2 As IXMLDOMNodeList

Function ПОЛУЧИТЬСЕРИЙНИК(Строка As String)
    Dim str As String
    str = Trim(Строка)
    If Len(str) > 1 Then
        Do While str Like "*[;:-/]"
            str = Trim(Left(str, Len(str) - 1))
        Loop
        ПОЛУЧИТЬСЕРИЙНИК = Trim(Replace(Replace(Replace(Replace(Replace(Строка, "сч. №", "", , , vbTextCompare), "сч.№", "", , , vbTextCompare), "№", ""), ",", ""), ".", ""))
    End If
    ПОЛУЧИТЬСЕРИЙНИК = str

End Function

Function ПОЛУЧИТЬСЕРИЙНИК(Строка As String)
    Dim str As String
    str = Trim(Строка)
    If Len(str) > 1 Then
        Do While str Like "*[;:-\/\\]" And Len(str) > 1
            str = Trim(Left(str, Len(str) - 1))
        Loop
        ПОЛУЧИТЬСЕРИЙНИК = Trim(Replace(Replace(Replace(Replace(Replace(Replace(str, "сч. №", "", , , vbTextCompare), "сч.№", "", , , vbTextCompare), "№", ""), ",", ""), ".", ""), "*", ""))
    Else
        ПОЛУЧИТЬСЕРИЙНИК = str
    End If
End Function

Sub PasteToVisible()
    Dim copyrng As Range, pasterng As Range
    Dim cell As Range, i As Long, newrng As Range
  
   'запрашиваем у пользователя по очереди диапазоны копирования и вставки
    Set copyrng = Application.InputBox("Диапазон копирования", "Запрос", Type:=8)
    Set pasterng = Application.InputBox("Диапазон вставки", "Запрос", Type:=8)
    
    'проверяем, чтобы они были одинакового размера
    If pasterng.SpecialCells(xlCellTypeVisible).Cells.Count <> copyrng.SpecialCells(xlCellTypeVisible).Cells.Count Then
        MsgBox "Диапазоны копирования и вставки разного размера!", vbCritical
        Exit Sub
    End If
  
    i = 1
    For Each cell In pasterng
        If cell.EntireRow.Hidden = False Then
            cell.value = copyrng.SpecialCells(xlCellTypeVisible).Cells(i).value
            i = i + 1
        End If
    Next cell
End Sub

sФ = Split(s, " ", 1)

Workbooks.Open sPath & objFile.Name, 0, , , , , , , , , , , , , xlNormalLoad

ActiveWorkbook.BuiltinDocumentProperties("Creation Date")

Workbooks.Open sPath & objFile.Name, 0, , , , , , , , , , , , , xlRepairFile

ЕСЛИ(НЕ(ЕОШ(ПОИСК("Ф-";R248)));"вариант1";"вариант2")

Sub issue_a_warning(x As Long, Optional ByVal txt As String = "В строке есть замечания!")
    If ActiveSheet.Cells(x, 2).Interior.Color <> vbRed Then
        ActiveSheet.Cells(x, 2).Interior.Color = vbRed
        ActiveSheet.Cells(x, 2).AddComment
        ActiveSheet.Cells(x, 2).Comment.Text Text:=txt
        ActiveSheet.Cells(x, 2).Comment.Visible = True
        ActiveSheet.Cells(x, 2).Comment.Shape.Select True
        With Selection
            .AutoSize = True
        End With
        ActiveSheet.Cells(x, 2).Comment.Shape.Select False
    End If
End Sub

issue_a_warning (cell.Row)

issue_a_warning (cell.Row, "В источнике задвоение!")

Sub Найти_полный_sn()
    Dim Путь As String, Файл As String, sn As Range, Совпадений As Integer, i%, rng As Range
    Dim sh As Worksheet
    Dim Книга As Excel.Workbook
    
    'выбираем папку с файлами-источниками информации
    With Application.FileDialog(msoFileDialogFolderPicker)
        .ButtonName = "OK"
        .Title = "Выберите папку, содержащую файлы Excel"
        If .Show = 0 Then
            Exit Sub
        End If
        Путь = .SelectedItems(1)
    End With
    Файл = Dir(PathName:=Путь + "\*.xls")
    i = 2
    Set sn = ActiveSheet.Cells(i, 2)
    
    Do Until sn.Value = "" 'пока не закончатся серийные номера в столбце
       Совпадений = 0
       Do Until Файл = "" 'пока не закончатся файлы в выбранной папке
           Set Книга = Workbooks.Open(Путь + "\" + Файл)
           For Each sh In Книга.Sheets 'поиск по листам
               sh.Activate
               Set rng = sh.UsedRange.Find(What:=sn.Value, LookIn:=xlValues, LookAt:=xlPart)
                If Not (rng Is Nothing) Then
                    Совпадений = 1
                    sn.Offset(0, Совпадений).Value = rng.Value
                    Do Until rng Is Nothing
                        Set rng = sh.UsedRange.FindNext(rng)
                        If Not (rng Is Nothing) Then
                            Совпадений = Совпадений + 1
                            sn.Offset(0, Совпадений).Value = rng.Value
                        End If
                    Loop
                End If
           Next sh
           Книга.Close
           Файл = Dir
       Loop
       i = i + 1
       sn = ActiveSheet.Cells(i, 2).Value 'следующий серийник
    Loop
    Set Книга = Nothing
End Sub

Sub транспонирование_пирамидаAPI()
    Dim sn As Range, i%, j%
    i = 2
    j = 0
    sn = ActiveSheet.Cells(i, 2)
    Do Until sn.Value = ""
        If Not sn.Characters(1, 1).Font.Bold Then
         j = j + 1
         sn.Offset(1, -j).Value = sn.Value
        Else
          j = 0
        End If
        i = i + 1
        sn = ActiveSheet.Cells(i, 2)
    Loop
End Sub