if Text.StartsWith([текст], "1") or Text.StartsWith ([текст], "2")  then 1 else [текст]

Sub SaveFirstSheetAsPDFwvbsfb()
    Dim filesToOpen As Variant
    Dim fileName As Variant
    Dim fileCounter As Integer
    Dim targetFolder As String
    Dim ws As Worksheet
    Dim proj_name As Integer
    
    filesToOpen = Application.GetOpenFilename("Excel files (*.xls*), *.xls*", , "Shoose your Excel files", , True)

Application.ScreenUpdating = False
    ' Задание папки назначения куда сохраняются файлы
    targetFolder = "S:\smth\smth\smth\smth\smth\smth\2023"

' Перебор выбранных файлов
    For fileCounter = LBound(filesToOpen) To UBound(filesToOpen)

        fileName = filesToOpen(fileCounter)

        Workbooks.Open fileName

        Set ws = ActiveWorkbook.Sheets(1)
        proj_name = Left(Right(ws.Cells(1, 3).End(xlDown).Offset(1, 0).Value, 4), 3)

        ws.ExportAsFixedFormat Type:=xlTypePDF, fileName:=targetFolder & "\" & "Inv " & Left(ws.Name, 31) & " summary_proj " & "proj_name" & ".pdf"
        ActiveWorkbook.Close SaveChanges:=False
    Next fileCounter
    
Application.ScreenUpdating = True
    MsgBox "Done. All sheets have been saved successfully"
    
End Sub

=Folder.Files("путь к папке")

Sub lknb()

'просуммировать значения в нарастании по ключам
Dim d1 As Object, i As Integer, j As Integer
Dim a, b, c

Range("b1").EntireColumn.Clear

'пилим словарь
Set d1 = CreateObject("scripting.dictionary")

'массив с нарастающим итогом. КЛЮЧИ
a = Range("a4").CurrentRegion
'массив статей, которые попадут в нарастающий итог. ИТЕМЫ в 1 столбце массива
b = Range("d4").CurrentRegion

'циклом назначаем пару ключ/итем. Итемы будут = 0, потому что
'надо собрать сумму в нарастании из другого места
For i = 1 To UBound(a, 1)
    d1.Add a(i, 1), 0
Next

'прохожусь по статьям в массиве b. Если есть ключ существует, тогда
'к итему с 0 суммой прибавляется сумма привязанная к этому ключу
For i = 1 To UBound(b, 1)
   If d1.Exists(b(i, 1)) Then d1(b(i, 1)) = d1(b(i, 1)) + b(i, 2)
   Debug.Print d1(b(i, 1))
Next

c = d1.Items

For i = 1 To UBound(a, 1)
    Cells(i + 3, 2).Value = d1.Items()(i - 1)
Next

End Sub

"If d1.exists (b(i,1)) then"

Sub lknb()

'просуммировать значения в нарастании по ключам
Dim d1 As Object, i As Integer, j As Integer
Dim a, b, c

'пилим словарь
Set d1 = CreateObject("scripting.dictionary")

'массив с нарастающим итогом
a = Range("a4").CurrentRegion
'массив сттатей, которые попадут в нарастающий итог
b = Range("d4").CurrentRegion

For i = 1 To UBound(a, 1)
    d1.Add a(i, 1), 0
Next

'прохожусь по статьям в массиве b. Если есть ключ сущестует, тогда
'к итему с 0 суммой прибавляется сумма привязанная к этому ключу
For i = 1 To UBound(b, 1)
    If d1.Exists((a(1, 1))) Then d1(a(1, 1)) = d1(a(1, 1)) + b(i, 2)
Next

'массив для вставки сложенных в нарастании итемов (сумм) по ключам
'ReDim c(1 To UBound(a, 1), 1 To 1)

c = d1(a(1, 1))

Stop
End Sub

Sub wvlkmfb()
Dim d1 As Object, i As Integer, j As Integer
Dim ilastrow As Integer, a, c

Set d1 = CreateObject("scripting.dictionary")
ilastrow = Cells(Rows.Count, 1).End(xlUp).Row

For i = 1 To ilastrow
    d1.Add Cells(i, 2).Value, Cells(i, 3).Value
Next

a = Range("g5").CurrentRegion
ReDim c(UBound(a))

For i = 1 To UBound(a, 1)
    If d1.Exists(a(i, 1)) Then c(i - 1) = d1.Item(a(i, 1))
Next

'Range("h5").Resize(UBound(c), 1).Value = c

For i = 5 To 8
    Range("h" & i).Value = c(i - 5)
Next


End Sub

            ActiveSheet.Rows(1).AutoFilter Field:=4, Criteria1:="<=" & CDbl(idate)