Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Поиск значений и отображение их в соседнем столбце - Мир MS Excel

  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Поиск значений и отображение их в соседнем столбце
Milirina555 Дата: Вторник, 15.04.2025, 12:33 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

В моём макросе все найденные значения выводятся в ячейку С4 через запятую, а мне необходимо чтобы каждое значение выводилось в новую ячейку, например С4, С5, С6 и т.д.

[vba]
Код
Sub Поиск()
Dim searchValue As String
Dim cell As Range
Dim result As String
Dim searchRange As Range

' Получаем значение для поиска из ячейки B1
searchValue = ThisWorkbook.Sheets("Лист1").Range("B1").Value

' Указываем диапазон для поиска
Set searchRange = ThisWorkbook.Sheets("Лист1").Range("A1:A20")

' Инициализируем переменную для хранения результата
result = ""

' Проходим по каждой ячейке в указанном диапазоне
For Each cell In searchRange
If InStr(1, cell.Value, searchValue, vbTextCompare) > 0 Then
' Если найдено совпадение, добавляем значение в результат
result = result & cell.Value & ", "
End If
Next cell

' Удаляем последнюю запятую и пробел, если есть совпадения
If Len(result) > 0 Then
result = Left(result, Len(result) - 2)
End If

' Выводим найденные значения в ячейку C4
ThisWorkbook.Sheets("Лист1").Range("C4").Value = result
End Sub
[/vba]
 
Ответить
СообщениеВ моём макросе все найденные значения выводятся в ячейку С4 через запятую, а мне необходимо чтобы каждое значение выводилось в новую ячейку, например С4, С5, С6 и т.д.

[vba]
Код
Sub Поиск()
Dim searchValue As String
Dim cell As Range
Dim result As String
Dim searchRange As Range

' Получаем значение для поиска из ячейки B1
searchValue = ThisWorkbook.Sheets("Лист1").Range("B1").Value

' Указываем диапазон для поиска
Set searchRange = ThisWorkbook.Sheets("Лист1").Range("A1:A20")

' Инициализируем переменную для хранения результата
result = ""

' Проходим по каждой ячейке в указанном диапазоне
For Each cell In searchRange
If InStr(1, cell.Value, searchValue, vbTextCompare) > 0 Then
' Если найдено совпадение, добавляем значение в результат
result = result & cell.Value & ", "
End If
Next cell

' Удаляем последнюю запятую и пробел, если есть совпадения
If Len(result) > 0 Then
result = Left(result, Len(result) - 2)
End If

' Выводим найденные значения в ячейку C4
ThisWorkbook.Sheets("Лист1").Range("C4").Value = result
End Sub
[/vba]

Автор - Milirina555
Дата добавления - 15.04.2025 в 12:33
doober Дата: Вторник, 15.04.2025, 12:42 | Сообщение № 2
Группа: Друзья
Ранг: Ветеран
Сообщений: 993
Репутация: 345 ±
Замечаний: 0% ±

Excel 2010
Где то так[vba]
Код
Sub Поиск()
    Dim searchValue As String
    Dim cell As Range, out(), ct&
    Dim result As String
    Dim searchRange As Range

    ' Получаем значение для поиска из ячейки B1
    searchValue = ThisWorkbook.Sheets("Лист1").Range("B1").Value

    ' Указываем диапазон для поиска
    Set searchRange = ThisWorkbook.Sheets("Лист1").Range("A1:A20")
    ReDim out(1 To searchRange.Rows.Count, 1 To 1)

    ' Инициализируем переменную для хранения результата
    result = ""

    ' Проходим по каждой ячейке в указанном диапазоне
    For Each cell In searchRange
        If InStr(1, cell.Value, searchValue, vbTextCompare) > 0 Then
            ' Если найдено совпадение, добавляем значение в результат
            ct = ct + 1
            out(ct, 1) = cell.Value
        End If
    Next cell

    ' Выводим найденные значения в ячейку C4
    If ct > 0 Then
    ThisWorkbook.Sheets("Лист1").Range("C4").Resize(ct, 1) = out
    End If
End Sub
[/vba]


 
Ответить
СообщениеГде то так[vba]
Код
Sub Поиск()
    Dim searchValue As String
    Dim cell As Range, out(), ct&
    Dim result As String
    Dim searchRange As Range

    ' Получаем значение для поиска из ячейки B1
    searchValue = ThisWorkbook.Sheets("Лист1").Range("B1").Value

    ' Указываем диапазон для поиска
    Set searchRange = ThisWorkbook.Sheets("Лист1").Range("A1:A20")
    ReDim out(1 To searchRange.Rows.Count, 1 To 1)

    ' Инициализируем переменную для хранения результата
    result = ""

    ' Проходим по каждой ячейке в указанном диапазоне
    For Each cell In searchRange
        If InStr(1, cell.Value, searchValue, vbTextCompare) > 0 Then
            ' Если найдено совпадение, добавляем значение в результат
            ct = ct + 1
            out(ct, 1) = cell.Value
        End If
    Next cell

    ' Выводим найденные значения в ячейку C4
    If ct > 0 Then
    ThisWorkbook.Sheets("Лист1").Range("C4").Resize(ct, 1) = out
    End If
End Sub
[/vba]

Автор - doober
Дата добавления - 15.04.2025 в 12:42
Milirina555 Дата: Вторник, 15.04.2025, 14:48 | Сообщение № 3
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

doober, Огромное спасибо! Вы просто чудо! Все работает именно так, как нужно

Можете ещё подсказать, возможно ли сделать, чтобы предыдущие найденные значения в столбцах С4, С5 и т.д. очищались с поиском новых значений?
 
Ответить
Сообщениеdoober, Огромное спасибо! Вы просто чудо! Все работает именно так, как нужно

Можете ещё подсказать, возможно ли сделать, чтобы предыдущие найденные значения в столбцах С4, С5 и т.д. очищались с поиском новых значений?

Автор - Milirina555
Дата добавления - 15.04.2025 в 14:48
MikeVol Дата: Вторник, 15.04.2025, 19:44 | Сообщение № 4
Группа: Проверенные
Ранг: Обитатель
Сообщений: 423
Репутация: 92 ±
Замечаний: 0% ±

MSO LTSC 2021 EN
[vba]
Код
    ' Выводим найденные значения в ячейку C4
    If ct > 0 Then

        With ThisWorkbook.Sheets("Лист1")
            .Range("C4", .Range("C4").End(xlDown)).ClearContents
            .Range("C4").Resize(ct, 1) = out
        End With

    End If

[/vba]


Ученик.
Одесса - Украина


Сообщение отредактировал MikeVol - Среда, 16.04.2025, 13:23
 
Ответить
Сообщение[vba]
Код
    ' Выводим найденные значения в ячейку C4
    If ct > 0 Then

        With ThisWorkbook.Sheets("Лист1")
            .Range("C4", .Range("C4").End(xlDown)).ClearContents
            .Range("C4").Resize(ct, 1) = out
        End With

    End If

[/vba]

Автор - MikeVol
Дата добавления - 15.04.2025 в 19:44
Milirina555 Дата: Среда, 16.04.2025, 12:57 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

MikeVol, к сожалению не работает ( результаты перестали выводиться
 
Ответить
СообщениеMikeVol, к сожалению не работает ( результаты перестали выводиться

Автор - Milirina555
Дата добавления - 16.04.2025 в 12:57
MikeVol Дата: Среда, 16.04.2025, 13:22 | Сообщение № 6
Группа: Проверенные
Ранг: Обитатель
Сообщений: 423
Репутация: 92 ±
Замечаний: 0% ±

MSO LTSC 2021 EN
Milirina555, А так? Смотрите выше в моём посте, изминил сообшение.


Ученик.
Одесса - Украина
 
Ответить
СообщениеMilirina555, А так? Смотрите выше в моём посте, изминил сообшение.

Автор - MikeVol
Дата добавления - 16.04.2025 в 13:22
Milirina555 Дата: Среда, 16.04.2025, 13:42 | Сообщение № 7
Группа: Пользователи
Ранг: Прохожий
Сообщений: 5
Репутация: 0 ±
Замечаний: 0% ±

MikeVol, Да, все работает, как надо!) Большое спасибо :angel:


Сообщение отредактировал Milirina555 - Среда, 16.04.2025, 13:43
 
Ответить
СообщениеMikeVol, Да, все работает, как надо!) Большое спасибо :angel:

Автор - Milirina555
Дата добавления - 16.04.2025 в 13:42
MikeVol Дата: Среда, 16.04.2025, 20:09 | Сообщение № 8
Группа: Проверенные
Ранг: Обитатель
Сообщений: 423
Репутация: 92 ±
Замечаний: 0% ±

MSO LTSC 2021 EN
Да, все работает
А логика таже была что в первой версии что во второй версии кода от меня что очень странно для меня. Ну да ладно, ни и отлично что у вас заработал код.


Ученик.
Одесса - Украина
 
Ответить
Сообщение
Да, все работает
А логика таже была что в первой версии что во второй версии кода от меня что очень странно для меня. Ну да ладно, ни и отлично что у вас заработал код.

Автор - MikeVol
Дата добавления - 16.04.2025 в 20:09
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2025 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!