Страницы: 1
RSS
VBA поиск (при необходимости) не первого, а следующего совпадения
 
Доброе утро! Ребят этот код работает хорошо, НО не всегда нужно именно первое совпадение, бывает так что нужно второе. К примеру в 34 столбце появляется цифра которая будет определять какое совпадение нужно выводить, в случае если 34 столбец пустой то искать и выдававть первое. Я понял что не разберусь в VBA сам поэтому обращаюсь к Вам. Спасибо
Код
Private Sub Worksheet_Change(ByVal Target As Range)

'If Target.Cells.Count > 1 Then Exit Sub
'If IsEmpty(Target) Then Exit Sub
If Not Intersect(Target, Range("P1:P100000")) Is Nothing Then

EE = ActiveCell.Row - 1

If IsEmpty(Cells(EE, 17)) = True Then

R = Cells(EE, 9) & " " & Cells(EE, 10) & " " & Cells(EE, 12) & "х" & Cells(EE, 13) & " - " & Cells(EE, 14) & "х" & Cells(EE, 15) & " марка-" & Cells(EE, 20)
R = LCase(R)
Cells(EE, 53) = R

Dim FoundValue As Range

     With Worksheets("База АоРПИ")
     TT = Cells(EE, 53)
      
       Set FoundValue = .Columns(53).Find(TT, , xlValues, xlWhole)
       If FoundValue Is Nothing Then Exit Sub
       
         .Range(.Cells(FoundValue.Row, 9), .Cells(FoundValue.Row, 22)).Copy Cells(EE, 17)
   
     End With

Else: Exit Sub
End If
End If

End Sub
 
https://coderoad.ru/39685676
Если нужны все совпадения, то
https://coderoad.ru/52879794
 
Спасибо Вам
 
Цитата
Marat Ta написал:
https://coderoad.ru/39685676

Добрый день, первая ссылка это формула а нужен именно код.
Сейчас данный код ищет только первое совпадение а бывает нужно то третье то пятое то второе и т.д
Поэтому в 34 столбце стоит цифра которая означает какое совпадение нужно вывести
 
Код
Private Sub Worksheet_Change(ByVal Target As Range)
    'If Target.Cells.Count > 1 Then Exit Sub
    'If IsEmpty(Target) Then Exit Sub
    If Not Intersect(Target, Range("P1:P100000")) Is Nothing Then
        
        Dim EE As Long
        EE = ActiveCell.Row - 1
         
        If IsEmpty(Cells(EE, 17)) = True Then
         
        Dim R As String
        R = Cells(EE, 9) & " " & Cells(EE, 10) & " " & Cells(EE, 12) & "х" & Cells(EE, 13) & " - " & Cells(EE, 14) & "х" & Cells(EE, 15) & " марка-" & Cells(EE, 20)
        R = LCase(R)
        Application.EnableEvents = False
        Cells(EE, 53) = R
        Application.EnableEvents = True
         
        Dim FoundValue As Range
         
        With Worksheets("База АоРПИ")
            'TT = Cells(EE, 53)
            
            Dim v34 As Variant
            v34 = Cells(Target.Row, 34).Value
            Dim f As Boolean
            If Not IsEmpty(v34) Then
                If IsNumeric(v34) Then
                    f = True
                End If
            End If
            
            If f Then
                Dim i As Long
                Dim y As Long
                Dim arr As Variant
                y = .Cells(.Rows.Count, 53).End(xlUp).Row
                If y = 1 Then y = 2
                arr = .Range(.Cells(1, 53), .Cells(y, 53))
                For y = 1 To UBound(arr, 1)
                    If arr(y, 1) = R Then i = i + 1
                    If i = v34 Then
                         Set FoundValue = .Cells(y, 53)
                        Exit For
                    End If
                Next
            Else
                Set FoundValue = .Columns(53).Find(R, , xlValues, xlWhole)
            End If
            
            If FoundValue Is Nothing Then Exit Sub
            .Range(.Cells(FoundValue.Row, 9), .Cells(FoundValue.Row, 22)).Copy Cells(EE, 17)
        End With
         
        Else: Exit Sub
        End If
    End If
End Sub
 
Цитата
МатросНаЗебре написал:
2021 10:59:55
Да вы ГЕНИЙ!!!!спасибо огромное!
Страницы: 1
Наверх