Поиск значений в книге (по слову) и вывод их в столбец

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Поиск значений в книге (по слову) и вывод их в столбец (Макросы/Sub)

odeon16

Дата: Четверг, 27.07.2017, 09:16 | Сообщение № 1

Группа: Пользователи

Ранг: Участник

Сообщений: 85

Репутация: 0 ±

Замечаний: 0% ±

Excel 2013

Доброе утро, форумчане.
Помогите разобраться с проблемой.

Есть рабочая книга с несколькими листами.
На листах разбросаны желтые, красные и синие ячейки с разными надписями, например Один (в желтых ячейках), Два (в синих), Три (в красных).

Рядом с каждой ячейкой есть еще несколько зеленых ячеек.
Каждая зеленая ячейка - расположена от желтой - на разных расстояниях.
В зеленые ячейки - вписаны разнообразные символы.

На листе4 есть столбец, в заголовке которого стоит одно из слов, записанных в желтую ячейку - например слово "Один".

Как макросом вывести в этот столбец - содержимое зеленых ячеек (на разных листах), расположенных в непосредственной близости с желтыми ячейками ?
(поиск идет - по тексту вписанному в ячейку F7 листа4. В данном случае - по слову "Один")
(Те зеленые ячейки, что не соседствуют с желтой, то есть находятся в некотором отдалении - не воспринимаются)

К сообщению приложен файл: 28678.xls (33.0 Kb)

Ответить

sboy

Дата: Четверг, 27.07.2017, 12:14 | Сообщение № 2

Группа: Друзья

Ранг: Участник клуба

Сообщений: 2566

Репутация: 724 ±

Замечаний: 0% ±

Excel 2010

Добрый день.
Не понял про цвет ячеек, он только для наглядности примера? или в желтой ячейке может быть и "два" и "три"
Сделал без цвета[vba]

Код

Sub Овал1_Щелчок()
sText = Range("F7").Value
Range("F8:F100").ClearContents
Dim arr()
ReDim arr(0)
    For x = 1 To 3
        With Sheets(x).UsedRange
        Set cl = .Find(sText, LookIn:=xlValues, lookat:=xlWhole)
            If Not cl Is Nothing Then
                firstAddress = cl.Address
                Do
                   For r = -1 To 1
                        For c = -1 To 1
                            q = cl.Offset(r, c).Value
                            If Not IsEmpty(q) And IsNumeric(q) Then
                    arr(UBound(arr)) = q
                    ReDim Preserve arr(UBound(arr) + 1)
                            End If
                        Next c
                    Next r
                    Set cl = .FindNext(cl)
                Loop While Not cl Is Nothing And cl.Address <> firstAddress
            End If
        End With
    Next x
    Range("F8").Resize(UBound(arr) + 1, 1) = WorksheetFunction.Transpose(arr)
End Sub

[/vba]