---

Sub TransferStrictStructure()
    Dim sh1 As Worksheet, sh2 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long
    Dim i As Long, j As Long
    Dim fileCode As String
    Dim foundRow As Long
    Dim textData As String
    Dim fullText As String
    Dim colOffset As Long
    
    ' Настраиваем листы
    Set sh1 = ThisWorkbook.Sheets("Лист1")
    Set sh2 = ThisWorkbook.Sheets("Лист2")
    
    lastRow1 = sh1.Cells(sh1.Rows.Count, 1).End(xlUp).Row
    lastRow2 = sh2.Cells(sh2.Rows.Count, 1).End(xlUp).Row
    
    ' Проходим по всем строкам Листа 2
    For i = 2 To lastRow2
        fileCode = sh2.Cells(i, 1).Value
        If InStr(fileCode, ".docx") > 0 Then
            fileCode = Left(fileCode, InStr(fileCode, ".docx") - 1)
        End If
        
        ' Ищем объект в Листе 1 (столбец A - номер ЦТП)
        foundRow = 0
        For j = 2 To lastRow1
            If sh1.Cells(j, 1).Value = fileCode Then
                foundRow = j
                Exit For
            End If
        Next j
        
        If foundRow > 0 Then
            ' Собираем ВЕСЬ текст из строки Листа 2 (столбцы 2-50)
            fullText = ""
            For j = 2 To 50
                If sh2.Cells(i, j).Value <> "" Then
                    fullText = fullText & " " & sh2.Cells(i, j).Value
                End If
            Next j
            
            ' ========================================
            ' 1. ИЩЕМ ГВС
            ' ========================================
            Dim gvsStart As Long, gvsEnd As Long
            Dim gvsText As String
            gvsText = ExtractSection(fullText, "ГВС", "Отопление|ЦО|ХВС|Подпитка|Гребёнка|Вентиляция|Т/С|ПО|$")
            
            If gvsText <> "" Then
                ' Заполняем ГВС: КЗР, датчик давления, датчик температуры
                Call FillEquipment(sh1, foundRow, gvsText, "ГВС")
            End If
            
            ' ========================================
            ' 2. ИЩЕМ ЦО (Отопление)
            ' ========================================
            Dim tsoText As String
            tsoText = ExtractSection(fullText, "Отопление|ЦО", "ГВС|ХВС|Подпитка|Гребёнка|Вентиляция|Т/С|ПО|Ввод|$")
            
            If tsoText = "" Then
                tsoText = ExtractSection(fullText, "Т/С", "ГВС|Отопление|ХВС|Подпитка|Гребёнка|Вентиляция|ПО|Ввод|$")
            End If
            
            If tsoText <> "" Then
                ' Заполняем ЦО: КЗР, датчик давления, датчик температуры
                Call FillEquipment(sh1, foundRow, tsoText, "ЦО")
            End If
            
            ' ========================================
            ' 3. ИЩЕМ ВВОД (ХВС)
            ' ========================================
            Dim hvText As String
            hvText = ExtractSection(fullText, "ХВС|Ввод", "ГВС|Отопление|ЦО|Подпитка|Гребёнка|Вентиляция|Т/С|ПО|$")
            
            If hvText <> "" Then
                ' Заполняем ВВОД: КЗР, датчик давления, датчик температуры
                Call FillEquipment(sh1, foundRow, hvText, "ВВОД")
            End If
        End If
    Next i
    
    MsgBox "Данные перенесены!"
End Sub

' ============================================================
' Функция: извлекает секцию текста между ключевыми словами
' ============================================================
Function ExtractSection(text As String, startKeyword As String, endKeyword As String) As String
    Dim startPos As Long, endPos As Long
    Dim startPatterns() As String
    Dim endPatterns() As String
    Dim p As Long
    Dim result As String
    
    ' Разбиваем ключевые слова
    startPatterns = Split(startKeyword, "|")
    endPatterns = Split(endKeyword, "|")
    
    result = ""
    
    ' Ищем начало секции
    For p = 0 To UBound(startPatterns)
        startPos = InStr(1, text, startPatterns(p), vbTextCompare)
        If startPos > 0 Then Exit For
    Next p
    
    If startPos = 0 Then
        ExtractSection = ""
        Exit Function
    End If
    
    ' Ищем конец секции (следующее ключевое слово)
    endPos = Len(text) + 1
    For p = 0 To UBound(endPatterns)
        If endPatterns(p) <> "$" Then
            Dim pos As Long
            pos = InStr(startPos + 1, text, endPatterns(p), vbTextCompare)
            If pos > 0 And pos < endPos Then
                endPos = pos
            End If
        End If
    Next p
    
    ' Извлекаем текст секции
    result = Trim(Mid(text, startPos, endPos - startPos))
    ExtractSection = result
End Function

' ============================================================
' Процедура: заполняет оборудование для конкретной системы
' ============================================================
Sub FillEquipment(sh As Worksheet, row As Long, sectionText As String, systemName As String)
    Dim colKZR As Long, colPress As Long, colTemp As Long
    Dim kzrText As String, pressText As String, tempText As String
    
    ' Определяем столбцы для системы
    Select Case systemName
        Case "ГВС"
            colKZR = FindColumnByKeyword(sh, "диаметр КЗР,ГВС")
            colPress = FindColumnByKeyword(sh, "датчик давления ГВС")
            colTemp = FindColumnByKeyword(sh, "датчик температуры ГВС")
        Case "ЦО"
            colKZR = FindColumnByKeyword(sh, "диаметр КЗР,ЦО")
            colPress = FindColumnByKeyword(sh, "датчик давления ЦО")
            colTemp = FindColumnByKeyword(sh, "датчик температуры ЦО")
        Case "ВВОД"
            colKZR = FindColumnByKeyword(sh, "диаметр КЗР,ВВОД")
            colPress = FindColumnByKeyword(sh, "датчик давления ВВОД")
            colTemp = FindColumnByKeyword(sh, "датчик температуры ВВОД")
        Case Else
            Exit Sub
    End Select
    
    ' Извлекаем КЗР (электроприводы, регулирующие клапаны)
    kzrText = ExtractEquipment(sectionText, "КЗР|Regada|Klimacc|Honeywell|TYP|Электропривод|МРП|AMV|ARV|TAFLINE|КПСР|TSL")
    If kzrText <> "" And colKZR > 0 Then
        If sh.Cells(row, colKZR).Value <> "" Then
            sh.Cells(row, colKZR).Value = sh.Cells(row, colKZR).Value & vbNewLine & kzrText
        Else
            sh.Cells(row, colKZR).Value = kzrText
        End If
    End If
    
    ' Извлекаем датчики давления
    pressText = ExtractEquipment(sectionText, "датчик давления|BD SENSORS|DMP|Корунд|СДВ|Сдв|DMP 331|DMP 330|Прома|DDM|МТ ЖКХ|КРТ|КОРУНД|Пульс|MBS|Овен|Элемер|ПД100")
    If pressText <> "" And colPress > 0 Then
        If sh.Cells(row, colPress).Value <> "" Then
            sh.Cells(row, colPress).Value = sh.Cells(row, colPress).Value & vbNewLine & pressText
        Else
            sh.Cells(row, colPress).Value = pressText
        End If
    End If
    
    ' Извлекаем датчики температуры
    tempText = ExtractEquipment(sectionText, "датчик температуры|ТСМУ|Орион|КТПТР|ТПТ|ТСМ|ТПУ|ТМТУ|ТСМ-|DTC|КТСП|ТМТ|Термопреобразователь|ТС035")
    If tempText <> "" And colTemp > 0 Then
        If sh.Cells(row, colTemp).Value <> "" Then
            sh.Cells(row, colTemp).Value = sh.Cells(row, colTemp).Value & vbNewLine & tempText
        Else
            sh.Cells(row, colTemp).Value = tempText
        End If
    End If
End Sub

' ============================================================
' Функция: извлекает оборудование из секции по ключевым словам
' ============================================================
Function ExtractEquipment(sectionText As String, keywords As String) As String
    Dim patterns() As String
    Dim p As Long
    Dim startPos As Long, endPos As Long
    Dim result As String
    Dim tempText As String
    
    patterns = Split(keywords, "|")
    result = ""
    tempText = sectionText
    
    ' Разбиваем секцию на строки
    Dim lines() As String
    lines = Split(tempText, vbNewLine)
    
    Dim line As Variant
    Dim found As Boolean
    
    For Each line In lines
        found = False
        For p = 0 To UBound(patterns)
            If InStr(1, line, patterns(p), vbTextCompare) > 0 Then
                found = True
                Exit For
            End If
        Next p
        
        If found Then
            If result <> "" Then
                result = result & vbNewLine & Trim(line)
            Else
                result = Trim(line)
            End If
        End If
    Next line
    
    ExtractEquipment = result
End Function

' ============================================================
' Функция: поиск столбца по ключевому слову в заголовке
' ============================================================
Function FindColumnByKeyword(sh As Worksheet, keyword As String) As Long
    Dim col As Long
    For col = 1 To 50
        If InStr(1, sh.Cells(1, col).Value, keyword, vbTextCompare) > 0 Then
            FindColumnByKeyword = col
            Exit Function
        End If
    Next col
    FindColumnByKeyword = 0
End Function