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

'пилим словарь
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

Sub wbk_fore_date()
'цель - что бы фильтр выдавал значение равные или меньше тем, что заданы в переменной idate

Dim wbkdate As Workbook, idate As Date
Dim wbkeight As Workbook

Set wbkeight = Workbooks("Книга8.xlsm")
'Set wbkdate = Workbooks.Add

wbkeight.Sheets("Лист1").Range("a16").Value = InputBox("Введите дату по которую нужно отфильтровать данные")
idate = wbkeight.Sheets("Лист1").Range("a16").Value
wbkeight.Sheets("Лист1").Range("$C$1:$C$14").AutoFilter Field:=1, Criteria1:="<=idate", Operator:=xlAnd

Stop
End Sub

Sub v1z1()
'дан диапазон чисел
'каждую строку переписать в обратном порядке

Dim i As Integer, j As Integer
Dim s As Range, rand As Integer
Dim irow As Integer, icol As Integer
Dim r As Integer, c As Integer
Dim cl As Range

'диапазон взял маленький, что бы было наглядней
Range("a1:b2").Select
Set s = Selection
irow = s.Rows.Count
icol = s.Columns.Count
r = s.Row
c = s.Column
s.ClearContents

'тут для начала наполняю диапазон рандомными числами
Randomize
For j = r To icol
    For i = c To irow
        rand = Int((1 * 100) * Rnd)
        Cells(i, j).Value = rand
    Next
Next

For Each cl In Selection
    
Next

Stop
End Sub

'обновление всех запросов PQ
For Each conn In ThisWorkbook.Connections
    conn.Refresh
Next conn