Запись в ячейку по строке и заголовку

Sub rtuuuuuuuuuu()
    Dim kol%, i%
    kol = 2
    ReDim a1$(kol), b1$(kol), c1#(kol)
    Dim str&, stlb&
    Dim rez As Range
 
    Dim ws As Worksheet
    Set ws = Worksheets("Ëèñò1")
 
    Dim rn As Range
    Set rn = ws.Range("A1:Z100")
  
    a1(1) = "Äëèíà"
    a1(2) = "Øèðèíà"
 
    b1(1) = "Óãîëîê-1"
    b1(2) = "Ñòåíêà-1"
 
    c1(1) = 15
    c1(2) = 16
 
    For i = 1 To kol
        With ws
            dWrite rn, a1(i), b1(i), c1(i)
         End With
    Next i
End Sub
 
 
Sub dWrite(ByVal rn As Range, ByVal a1 As String, ByVal b1 As String, ByVal c1 As String)
    Dim r As Range
    Dim c As Collection
    Dim i As Long, j As Long
    
    Dim m() As Variant, v1 As Variant, v2 As Variant
    
    Set c = New Collection
    m = rn
    For i = 1 To rn.Rows.Count
        If m(i, j) = a1 Then
            c.Add i
            Exit For
        End If
    Next i
    
    For j = 1 To rn.Columns.Count
        If m(i, j) = b1 Then
            c.Add j
            Exit For
        End If
    Next j
 
   For Each v1 In c
      Set r = Union(r, rn.Cells(v1, 1))
   Next v1
   r.Cells = c1
 
   For Each v2 In c
      Set r = Union(r, rn.Cells(1, v2))
   Next v2
    r.Cells = c1
End Sub

'Процедура заполнения базы данных всеми необходимыми значениями.
Sub rtuuuuuuuuuu()
    Dim ws As Worksheet
    Dim db As Range
 
    Dim i As Long, j As Long, rKol As Long, cKol As Long
    Dim rowSearches As Variant, colSearches As Variant
    Dim appropriateVals() As Double
    
    'Определяем, какие заголовки будем искать в строках и столбцах.
    rowSearches = Array("Уголок-1", "Стенка-1", "Уголок-2", "Стенка-2")
    colSearches = Array("Длина", "Ширина", "Высота")
    
    'Выделяем память для хранения значений, соответствующих заголовкам.
    rKol = UBound(rowSearches): cKol = UBound(colSearches)
    ReDim appropriateVals(rKol, cKol) As Double
    
    'Определяем соответствующие заголовкам значения.
    appropriateVals(0, 0) = 15  'Длина уголка-1 равна 15 ед.
    appropriateVals(0, 1) = 17  'Ширина уголка-1 равна 17 ед.
    appropriateVals(0, 2) = 100 'Высота уголка-1 равна 100 ед.
    appropriateVals(1, 0) = 50  'Длина стенки-1 равна 50 ед.
    appropriateVals(1, 1) = 16  'Ширина стенки-1 равна 16 ед.
    appropriateVals(1, 2) = 25  'Высота стенки-1 равна 25 ед.
    appropriateVals(2, 0) = 66  'и т.д.
    appropriateVals(2, 1) = 77
    appropriateVals(2, 2) = 88
    appropriateVals(3, 0) = 12
    appropriateVals(3, 1) = 23
    appropriateVals(3, 2) = 34
    'Примечание: этот участок кода можно изменить - например, можно заполнять
    'массив appropriateVals() данными из какого-нибудь внешнего источника.
    
    'Определяем диапазон базы данных.
    Set ws = Worksheets("Лист1")
    Set db = ws.Range("A1:Z100")
 
    'Заполняем ячейки базы данных, соответствующие определенным заголовкам.
    For i = 0 To rKol
        For j = 0 To cKol
            dWrite db, appropriateVals(i, j), rowSearches(i), colSearches(j)
        Next j
    Next i
End Sub

'Процедура заполняет ячейки базы данных Database, находящиеся на пересечении строки, чей первый столбец удовлетворяет условию RowSearch,
'и столбца, чья первая строка удовлетворяет условию ColSearch, значениями ValToIns.
Sub dWrite(ByVal Database As Range, ByVal ValToIns As Variant, ByVal RowSearch As String, ByVal ColSearch As String)
    Dim i As Long, j As Long, rNum As Long, cNum As Long
    Dim m As Variant, rh As Variant, ch As Variant
    With Database
        On Error GoTo ErrH
        rNum = .Rows.Count - 1      'Находим количество строк в базе (за исключением заголовков).
        cNum = .Columns.Count - 1   'Находим количество столбцов в базе (за исключением заголовков).
        m = .Cells(2, 2).Resize(rNum, cNum) 'В массив m() заносим значения базы данных, за исключением заголовков.
        rh = Application.Transpose(.Cells(2, 1).Resize(rNum, 1)) 'В массив rh() заносим заголовки строк.
        ch = Application.Transpose(Application.Transpose(.Cells(1, 2).Resize(1, cNum))) 'В массив ch() заносим заголовки столбцов.
        On Error GoTo 0
    End With
    For i = 1 To rNum   'Проходим циклом по заголовкам строк.
        If CStr(rh(i)) = RowSearch Then 'Если заголовок строки соответствует условию RowSearch, то...
            For j = 1 To cNum   'просматриваем в цикле также заголовки столбцов...
                'и если в заголовках столбцов тоже обнаруживается совпадение (на этот раз с условием ColSearch), то...
                If CStr(ch(j)) = ColSearch Then m(i, j) = ValToIns 'заполняем соответствующие элементы массива значениями ValToIns.
            Next j
        End If
    Next i
    Database.Cells(2, 2).Resize(rNum, cNum) = m 'Выгружаем обработанный массив в диапазон Database.
    Exit Sub
'Обработка ошибок.
ErrH:
    MsgBox "Процедура dWrite сообщает: база пуста - проверьте параметр Database процедуры."
    Err.Clear
End Sub

Sub tr()
...
 
    a1(1) = "Длина" - этих только одно значение
    a1(2) = "Ширина"
 
    b1(1) = "Уголок-1" ' - этих строк на листе может быть несколько... не хотелось бы всех их записывать.
    b1(2) = "Стенка-1" ' - и этих строк на листе может быть несколько... тоже не хотелось бы всех их записывать.
 
    c1(1) = 15 - данные
    c1(2) = 16
 
 ...
End Sub

Sub trvi2()
    Dim KolichestvoParUsloviy%, i%
    KolichestvoParUsloviy = 2
    'Is- неудачное имя для переменной, совпадает с оператором Is
    ReDim Iss$(KolichestvoParUsloviy), Si$(KolichestvoParUsloviy), Znachenie#(KolichestvoParUsloviy)
    Dim Stroka&, Stolbec&
    Dim RezPoiska As Range
    Iss(1) = "Длина"
    Iss(2) = "Ширина"
    Si(1) = "Уголок-1"
    Si(2) = "Стенка-1"
    Znachenie(1) = 15  ' Подставляемое значение для 1-ой пары
    Znachenie(2) = 16.9999 ' Подставляемое значение для 2-ой пары
    Application.ScreenUpdating = False ' для скрытности
   Workbooks.Open Filename:="C:\example.xlsx", UpdateLinks:=0, ReadOnly:=False
 For i = 1 To KolichestvoParUsloviy
   With ActiveWorkbook.Worksheets("1")
        Set RezPoiska = Range("A1:D10").Find(What:=Si(i), LookIn:=xlValues, _
            LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
        If RezPoiska Is Nothing Then
            MsgBox "Не найдено " & Si(i)
        Else
            Stolbec = RezPoiska.Column
        End If
        Set RezPoiska = Range("A1:D10").Find(What:=Iss(i), LookIn:=xlValues, _
            LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
        If RezPoiska Is Nothing Then
            MsgBox "Не найдено " & Iss(i)
        Else
            Stroka = RezPoiska.Row
        End If
        If Stroka > 0 And Stolbec > 0 Then
            Cells(Stroka, Stolbec) = Znachenie(i) ' Свое значение
        End If
    End With
Next i
    Application.ScreenUpdating = True
End Sub

    Si(1) = "Уголок-1"
    Si(2) = "Стенка-1"

a1=Уголок-1
a2=Стенка-1
 
b1=Длина
b2=Ширина
 
с1=12
с2=13
с3=14
с4=15

Sub Main()
...
    ar = WS.Range("A1:Z100")
 
    With WS
        Dim n As Integer = 15
        Dim b(0 To n) As String
 
        b(1)=10
        b(2)=11
        b(3)=12
        b(4)=13
        b(5)=14
        b(6)=15
        b(7)=16
        b(8)=17
        b(9)=18
        b(10)=19
        b(11)=20
        b(12)=21
        b(13)=22
        b(14)=23
        b(15)=24
 
        For i=1 To n
            ExCel = findAdr(a,b(i),ar)
        Next i
    End With
End Sub 
 
' функция ищет только однозначение
Function findAdr(x As String, y As String, WWS As Object) As Object
    With WWS
    Rez1 = WWS.Find(What:=x)    
    Rez2 = WWS.Find(What:=y)    
    If Rez2 Is Nothing Then
    MsgBox ("Не найдено " + y,0,":(")
    Else
    Strk=Rez1.Row
    Stlb=Rez2.Column
    Dim stroka As String =Strk
    Dim stolbec As String =Stlb
    'Присваеваем значению функции тело искомой ячейки
    findAdr = WWS.Cells(Strk,Stlb)
    'MsgBox ("Строка"+stroka+" Столбец"+stolbec,0,"Нашел!")   
    End If
    End With
End Function

Sub Main()
...
    ar = WS.Range("A1:Z100")
 
    With WS
        Dim n As Integer = 15
        Dim b(0 To n) As String
 
        b(1)=10
        b(2)=11
        b(3)=12
        b(4)=13
        b(5)=14
        b(6)=15
        b(7)=16
        b(8)=17
        b(9)=18
        b(10)=19
        b(11)=20
        b(12)=21
        b(13)=22
        b(14)=23
        b(15)=24
 
        For i=1 To n
            ExCel = findAdr(a,b(i),ar)
        Next i
    End With
End Sub 
 
' функция ищет только однозначение
Function findAdr(x As String, y As String, WWS As Object) As Object
    With WWS
    Rez1 = WWS.Find(What:=x)    
    Rez2 = WWS.Find(What:=y)    
    If Rez2 Is Nothing Then
    MsgBox ("Не найдено " + y,0,":(")
    Else
    Strk=Rez1.Row
    Stlb=Rez2.Column
    Dim stroka As String =Strk
    Dim stolbec As String =Stlb
    'Присваеваем значению функции тело искомой ячейки
    findAdr = WWS.Cells(Strk,Stlb)
    'MsgBox ("Строка"+stroka+" Столбец"+stolbec,0,"Нашел!")   
    End If
    End With
End Function

Sub Main()
wb = ActiveWorkbook
ws = wb.Sheets("Лист1") 
ar = ws.Range("A1:Z100")
 
    With ws
        Dim n As Integer = 3
        Dim a(0 To n) As String
        Dim b(0 To n) As String
 
        a(1) = "Уголок-1"
        a(2) = "Стенка-1"
        a(3) = "Втулка-1"
 
        b(1)="Длина"
        b(2)="Ширина"
        b(3)="Высота"
 
        For i=1 To n
            ExCel = findAdr(a(i),b(i),ar)
        Next i
    End With
End Sub 
 
Function findAdr(x As String, y As String, WWS As Object) As Object
    With WWS
    Rez1 = WWS.Find(What:=x)    
    Rez2 = WWS.Find(What:=y)    
    If Rez2 Is Nothing Then
    MsgBox ("Не найдено " + y,0,":(")
    Else
    Strk=Rez1.Row
    Stlb=Rez2.Column
    Dim stroka As String =Strk
    Dim stolbec As String =Stlb
    findAdr = WWS.Cells(Strk,Stlb)
    'MsgBox ("Строка"+stroka+" Столбец"+stolbec,0,"Нашел!") 
    End If
    End With
End Function

Sub ()
s(1) = Cells.Find(What:="Стенка-1").Row
 
For i=2 to n
s(i) = Cells.FindNext(After:=ActiveCell).Row
if s(i)<s(i-1) then
Exit sub
Else
Next i
 
End sub

Sub mIntersect()
 
 Dim rng1 As Range, rng2 As Range, currCell As Range
 Dim i&, j&, r&, c&, a&, b&, count_1&, count_2&
 Dim c1%, c2%, c3%, c4%
 Dim arr1(), arr2()
     
   a = Application.WorksheetFunction. _
                CountIf(Range("A:A"), "Óãîëîê-1")
   b = Application.WorksheetFunction. _
                CountIf(Range("A:A"), "Ñòåíêà-1")
   ReDim arr1(a)
   ReDim arr2(b)
   
   count_1 = 0
   count_2 = 0
   
       For Each currCell In Range("A:A")
            If currCell.Value = "Óãîëîê-1" Then
               count_1 = count_1 + 1
               arr1(count_1) = currCell.Row
            End If
            If currCell.Value = "Ñòåíêà-1" Then
               count_2 = count_2 + 1
              arr2(count_2) = currCell.Row
            End If
        Next
'--Verification---------
'Stop
'    For i = LBound(arr1) To UBound(arr1)
'        Debug.Print arr1(i)
'    Next 'i
'    For i = LBound(arr2) To UBound(arr2)
'        Debug.Print arr2(i)
'    Next 'i
'==End==Ver===========
Stop
    c1 = 15: c2 = 16: c3 = 35: c4 = 46
    For i = LBound(arr1) To UBound(arr1)
       Set currCell = Application.Intersect(Rows(arr1(i)), _
                            Range("b:b"))
            
            currCell = c1
        Set currCell = Application.Intersect(Rows(arr1(i)), _
                            Range("C:C"))
            currCell = c2
    Next 'i
    For i = LBound(arr2) To UBound(arr2)
       Set currCell = Application.Intersect(Rows(arr2(i)), _
                            Range("b:b"))
            currCell = c3
        Set currCell = Application.Intersect(Rows(arr2(i)), _
                            Range("C:C"))
            currCell = c4
    Next 'i
End Sub

Sub SearchPoz()
    Dim kol%, i%
    kol = 2
    ReDim a1$(1 To kol), b1$(1 To kol), c1#(1 To kol)
    Dim str&, stlb&
 
    Dim ws As Worksheet
    Set ws = Worksheets("Лист1")
 
    Dim rn As Range
    Set rn = ws.Range("A1:Z100")
 
    a1(1) = "Длина"
    a1(2) = "Ширина"
 
    b1(1) = "Уголок-1"
    b1(2) = "Стенка-1"
 
    c1(1) = 15
    c1(2) = 16
 
    For i = 1 To kol
        For Each el In findR(a1(i), b1(i), rn)
            Cells(--Split(el, "|")(0), --Split(el, "|")(1)).Value = c1(i)
        Next
    Next
 
End Sub
 
 
Private Function findR(cc As String, rr As String, rn As Range)
    Dim iCell As Range, crit&, out As New Collection, el, elel
    Dim rDic As Object, cDic As Object
    Set rDic = CreateObject("Scripting.Dictionary")
    Set cDic = CreateObject("Scripting.Dictionary")
 
    Set iCell = rn.Find _
                (What:=cc, LookIn:=xlValues, LookAt:=xlWhole)
 
    If Not iCell Is Nothing Then
        crit = crit + 1
        iAddress$ = iCell.Address
        Do
            Set iCell = rn.FindNext(After:=iCell)
            cDic.Item(iCell.Column) = 0&
        Loop While Not iCell Is Nothing And iCell.Address <> iAddress$
    End If
 
    Set iCell = rn.Find _
                (What:=rr, LookIn:=xlValues, LookAt:=xlWhole)
 
    If Not iCell Is Nothing Then
        crit = crit + 1
        iAddress$ = iCell.Address
        Do
            Set iCell = rn.FindNext(After:=iCell)
            rDic.Item(iCell.Row) = 0&
        Loop While Not iCell Is Nothing And iCell.Address <> iAddress$
    End If
 
    If crit = 2 Then
        For Each el In rDic
            For Each elel In cDic
                out.Add el & "|" & elel
            Next
        Next
    End If
 
    Set findR = out
End Function