Добавлено (2026-03-05, 12:01)
---------------------------------------------
' Главная процедура вставки подписей (ОПТИМИЗИРОВАННАЯ)
Sub InsertAllSignatures()
Dim signaturePath As String
Dim ws As Worksheet
Dim fso As Object
Dim startTime As Double

startTime = Timer

' Отключаем всё для скорости
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
.DisplayAlerts = False
End With

' Получаем путь из ячейки A5 на листе Титул
On Error Resume Next
Set ws = ThisWorkbook.Sheets("Титул")
If Not ws Is Nothing Then
signaturePath = Trim(ws.Range("A5").Value)
ws.Range("A5").ClearContents
End If
On Error GoTo 0

' Если путь пустой, используем запасной вариант
If signaturePath = "" Then
signaturePath = "C:\isihogy\Bin\binMR_vs\XlsUser\Signatures\"
End If

' Добавляем слеш если нужно
If Right(signaturePath, 1) <> "\" Then
signaturePath = signaturePath & "\"
End If

Set fso = CreateObject("Scripting.FileSystemObject")

' Проверяем существование папки (быстро)
If Not fso.FolderExists(signaturePath) Then
GoTo CleanExit
End If

Set signatures = CreateObject("Scripting.Dictionary")

' Загружаем подписи (ОДНИМ МАССИВОМ, быстро)
If Not LoadSignaturesFast(signaturePath) Then
GoTo CleanExit
End If

' Вставляем подписи (оптимизированно)
Call InsertTitulSignaturesFast

Set signatures = Nothing

CleanExit:
' Восстанавливаем настройки
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.DisplayAlerts = True
End With

Debug.Print "Вставка подписей: " & Timer - startTime & " сек"
End Sub

' БЫСТРАЯ загрузка подписей (без лишних проверок)
Function LoadSignaturesFast(path As String) As Boolean
Dim fso As Object
Dim folder As Object
Dim file As Object
Dim cnt As Integer

On Error GoTo ErrorHandler

Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(path)

cnt = 0
For Each file In folder.Files
If LCase(fso.GetExtensionName(file.Name)) = "png" Then
signatures.Add fso.GetBaseName(file.Name), file.Path
cnt = cnt + 1
End If
Next file

LoadSignaturesFast = (cnt > 0)
Exit Function

ErrorHandler:
LoadSignaturesFast = False
End Function

' БЫСТРАЯ вставка подписей (без дублирования проверок)
Sub InsertTitulSignaturesFast()
Dim ws As Worksheet
Dim findCell As Range
Dim nameCell As Range
Dim personName As String
Dim imagePath As String
Dim processedCells As Collection
Dim cellKey As String
Dim searchTerms As Variant
Dim i As Integer

On Error Resume Next
Set ws = ThisWorkbook.Sheets("Титул")
If ws Is Nothing Then Exit Sub
On Error GoTo 0

Set processedCells = New Collection

' ОСНОВНЫЕ МЕСТА ДЛЯ ПОДПИСЕЙ
searchTerms = Array("Буровой мастер", "Скважину документировал", "Документацию проверил")

Application.ScreenUpdating = False

For i = LBound(searchTerms) To UBound(searchTerms)
Set findCell = ws.Cells.Find(What:=searchTerms(i), LookIn:=xlValues, LookAt:=xlPart)
If Not findCell Is Nothing Then
' ФИО справа
Set nameCell = findCell.Offset(0, 1)
If IsEmpty(nameCell) Then Set nameCell = findCell.Offset(0, 2)
If IsEmpty(nameCell) Then Set nameCell = findCell.Offset(0, 3)
If IsEmpty(nameCell) Then Set nameCell = findCell.Offset(0, 4)

If Not IsEmpty(nameCell) Then
personName = ExtractPersonNameFast(CStr(nameCell.Value))
If personName <> "" Then
cellKey = "T" & nameCell.Row & "C" & nameCell.Column

On Error Resume Next
Dim dummy As Variant
dummy = processedCells(cellKey)
If Err.Number <> 0 Then
On Error GoTo 0
processedCells.Add cellKey, cellKey

imagePath = FindSignature(personName)
If imagePath <> "" Then
Call InsertImageFast(ws, nameCell, imagePath, personName)
End If
End If
End If
End If
End If
Next i

Application.ScreenUpdating = True
End Sub

' БЫСТРОЕ извлечение ФИО
Function ExtractPersonNameFast(text As String) As String
Dim parts As Variant
Dim i As Integer
Dim result As String

If text = "" Then Exit Function

parts = Split(text, " ")
result = ""

' Берем последние 2-3 слова (там точно ФИО)
For i = UBound(parts) To 0 Step -1
If Len(result) > 20 Then Exit For
result = parts(i) & " " & result
If i <= UBound(parts) - 3 Then Exit For
Next i

ExtractPersonNameFast = Trim(result)
End Function

' БЫСТРАЯ вставка изображения (без лишних проверок)
Sub InsertImageFast(ws As Worksheet, targetCell As Range, imagePath As String, personName As String)
Dim shape As Shape
Dim imgWidth As Double
Dim imgHeight As Double

' Проверяем наличие изображения (быстро)
For Each shape In ws.Shapes
If shape.Type = msoPicture Then
If Not shape.TopLeftCell Is Nothing Then
If shape.TopLeftCell.Row = targetCell.Row And _
shape.TopLeftCell.Column = targetCell.Column Then
Exit Sub
End If
End If
End If
Next shape

' Вставляем без лишних проверок
On Error Resume Next
Set shape = ws.Shapes.AddPicture( _
Filename:=imagePath, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=targetCell.Left, _
Top:=targetCell.Top, _
Width:=-1, _
Height:=-1)

If Err.Number <> 0 Then Exit Sub
On Error GoTo 0

' Быстрое масштабирование
imgHeight = Application.CentimetersToPoints(1.1)
imgWidth = imgHeight * (shape.Width / shape.Height)

shape.Width = imgWidth
shape.Height = imgHeight
shape.Top = targetCell.Top + (targetCell.Height - shape.Height) / 2
shape.Placement = xlFreeFloating

DoEvents
End Sub