Vba excel сравнить значения ячеек

1

06.09.2019, 16:26. Показов 12332. Ответов 10

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18

Sub reshen()
    Dim i As Integer
    Dim value As String
    Dim Celevye As Variant
    Dim TotalRows As Long
    Dim N As Integer
    TotalRows = Rows(Rows.Count).End(xlUp).Row
    Celevye = Array("Труба", "Гвоздь")
    N = 500
    Z = 50
            For j = 1 To Z
                For i = 1 To N
                    If InStr(1, Cells(i, 2), "Труба") <> 0 Then
                    Cells(i, 3) = "Труба"
                End If
                Next i
            Next j
End Sub

0

06.09.2019, 17:34

2

wtftaekwondo, Как говорится, меньше слов, а больше дел В общем, лучше приложите небольшой фрагмент таблиц, 1) что есть и 2) что должно получиться, после выполнения макроса.

0

06.09.2019, 17:56

 [ТС]

3

Хорошо. Вот две фотографии (пример).
Под колонкой F написаны слова, которые должны находиться в колонке «B».
В случае, если это слово содержится в ячейке, то справа оно должно записаться.

0

06.09.2019, 18:06

4

0

06.09.2019, 18:18

 [ТС]

5

За последние 2 строки извиняюсь, это идеальный вариант, которые уже обрабатывается вручную.
Необходимо просто получить «Направляющая».
Просто хотел побыстрее скинуть AS IS и TO BE поэтому не проверил.
Суть в том, чтобы третий столбец принял одно из значений массива из целевых слов (в моем примере их 3 слова).

0

06.09.2019, 18:33

6

=ИНДЕКС($F$1:$F$3;ПОИСКПОЗ(1;(СЧЁТЕСЛИ(B1;$F$1:$F$3&"*"));0))

1

06.09.2019, 18:45

 [ТС]

7

В целом тоже подойдет, спасибо)
Но если кто-то сталкивался с макросами и ему это будет знакомо, то хотелось бы еще и в VBA сделать.

0

06.09.2019, 21:31

8

Сообщение было отмечено wtftaekwondo как решение

Решение

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

Private Sub Test()
    Dim a1, a2, t, i1&, i2&
    a1 = Range("B1", Cells(Rows.Count, "B").End(xlUp)).Value
    a2 = Range("F1:F3").Value
    For i1 = 1 To UBound(a1)
        t = a1(i1, 1): a1(i1, 1) = Empty
        For i2 = 1 To 3
            If InStr(1, t, a2(i2, 1), vbTextCompare) = 1 Then
               a1(i1, 1) = a2(i2, 1)
               Exit For
            End If
        Next
    Next
    Range("C1").Resize(i1 - 1) = a1
End Sub

1
2
3
4
5
6
7
8
9
10
11

Private Sub Test2v1()
    Dim a1, a2, t, i&
    a1 = Range("B1", Cells(Rows.Count, "B").End(xlUp)).Value
    a2 = Range("F1:F3").Value
    For i = 1 To UBound(a1)
        t = Split(a1(i, 1))(0): a1(i, 1) = Empty
        If Not IsError( _
        Application.Match(t, a2, 0)) Then a1(i, 1) = t
    Next
    Range("C1").Resize(i - 1) = a1
End Sub

1
2
3
4
5
6
7
8
9
10

Private Sub Test2v2()
    Dim r As Range, a, t, i&
    a = Range("B1", Cells(Rows.Count, "B").End(xlUp)).Value
    Set r = Range("F1:F3")
    For i = 1 To UBound(a)
        t = Split(a(i, 1))(0): a(i, 1) = Empty
        If Application.CountIf(r, t) > 0 Then a(i, 1) = t
    Next
    Range("C1").Resize(i - 1) = a
End Sub

1

09.09.2019, 12:16

 [ТС]

9

1
2
3

t = Split(a(i, 1))(0): a(i, 1) = Empty
If Application.CountIf(r, t) > 0 Then a(i, 1) = t
Range("C1").Resize(i - 1) = a

0

09.09.2019, 13:01

10

0

13.09.2019, 13:51

11

Много вариантов, конечно

0

Sub DiffsColor()
'допускаем наличие пустых ячеек в середине  и конце диапазонов

'x = адрес верхней ячейки первого сравниваемого диапазона = значению в ячейке B2 на Лист2
'y = адрес верхней ячейки второго сравниваемого диапазона = значению в ячейке B3 на Лист2

x = ThisWorkbook.Sheets("Лист2").Range("B2")
y = ThisWorkbook.Sheets("Лист2").Range("B3")

xCol = Worksheets("Лист1").Range(x).Column 'колонка первого диапазона
xRow = Worksheets("Лист1").Range(x).Row 'строка начала первого диапазона
yCol = Worksheets("Лист1").Range(y).Column 'колонка второго диапазона
yRow = Worksheets("Лист1").Range(y).Row 'строка начала второго диапазона


xLastRow = Worksheets("Лист1").Cells(Rows.Count, xCol).End(xlUp).Row 'последняя строка первого диапазона
yLastRow = Worksheets("Лист1").Cells(Rows.Count, yCol).End(xlUp).Row 'последняя строка второго диапазона

MaxLastRow = Application.WorksheetFunction.Max(xLastRow - xRow + 1, yLastRow - yRow + 1)


Set lastcell = Worksheets("Лист1").Cells(MaxLastRow + 1, xCol)

Dim c As Range
'прогоняем сравнение от начальной заданной ячейки x до последней ячейки в этом столбце
For Each c In Worksheets("Лист1").Range(x, lastcell)
    If c.Value <> Worksheets("Лист1").Cells(yRow, yCol) Then
    c.Interior.ColorIndex = 42
    Worksheets("Лист1").Cells(yRow, yCol).Interior.ColorIndex = 42
    End If
    yRow = yRow + 1
Next c

End Sub