Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Макрос по поиску повторяющих значений и вывода их в таблицу, Исправить Макрос по поиску повторяющих значений и вывода их в таблицу
 
#1
27.04.2024 18:59:43
Добрый день, уважаемые эксперты.
Я только начал изучать VBA и попытался написать код по поиску повторяющих значений по части текста и вывода их в отдельную таблицу в виде построчных записей. К сожалению, что было многовероятно, у меня это не получилось.

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

У меня проблема в том, что макрос отрабатывает очень долго и в конце с результатом (неправильным) выдаёт ошибку. Также, при нажатии на отмену в диалоговом окне (ввода значения) макрос и Excel зависает (красится в серый и статус "Не отвечает".
Неправильный результат заключается в том, что правильное количество строк располагается неправильно в новой таблице (сдвигается на определённое количество строк влево.

Помогите, пожалуйста, разобраться где ошибка или подскажите как упростить мой код, чтобы я мог получить необходимый результат.
Заранее благодарен.
 
 
 
#2
27.04.2024 20:12:10
User2616,
Вы понимаете, что это платный раздел форума?
Возможно, есть понимание по цене?
Изменено: evgeniygeo - 27.04.2024 20:12:38
 
 
 
#3
28.04.2024 07:51:42
Доброе утро, evgeniygeo.
К сожалению, у меня нет понимания по цене.
А на обычный форум у меня получилось сделать такое сообщение.
 
 
 
#4
28.04.2024 09:04:16
Написал в личку
 
 
 
#5
28.04.2024 15:37:34
Перенесено по просьбе автора.
 
 
 
#6
28.04.2024 16:21:32
Активной должна быть ячейка из диапазона поиска.
Код
Sub Poisk()
Dim Rg1 As Range, Rg2 As Range, Ar1, Sh1 As Worksheet, Txt$, i&, j&, S!
Txt = InputBox("Укажите часть кода для поиска", "Поиск значений", "S8001")
If StrPtr(Txt) = 0 Then Exit Sub
Application.ScreenUpdating = False
S = Timer
Set Sh1 = ActiveWorkbook.ActiveSheet
Set Rg1 = ActiveCell.CurrentRegion
Ar1 = Rg1.Value
For i = 2 To UBound(Ar1): For j = 1 To UBound(Ar1, 2)
    If Ar1(i, j) Like "*" & Txt & "*" Then
If Rg2 Is Nothing Then Set Rg2 = Sh1.Cells(i + Rg1.Row - 1, j) Else Set Rg2 = Union(Rg2, Sh1.Cells(i + Rg1.Row - 1, j))
    Exit For
    End If
Next j, i
If Not Rg2 Is Nothing Then Union(Intersect(Rg2.EntireRow, Rg1), Rg1.Rows(1)).Copy Sh1.Range("H1")
Application.Goto Sh1.Range("H1"), True
Debug.Print Timer - S
End Sub
 
 
 
#7
30.04.2024 08:09:51
ТС исчез нигде не отвечает. Пользователи тему вроде смотрят. решил исправить макрос от ТС. По скорости он хуже, чем предыдущий, здесь цикл по ячейкам.
Код
Sub ПоискЗначения()
Dim RgAll As Range, rngOld As Range, varAnw As String
Dim wbkOne As Workbook: Set wbkOne = ThisWorkbook
Dim shtThis As Worksheet: Set shtThis = wbkOne.Worksheets("TDSheet")
Dim rngNew As Range: Set rngNew = shtThis.Range("H1:L1")
    shtThis.Range("H1:L10000").ClearContents
    varAnw = InputBox("Укажите часть кода для поиска", "Поиск значений", "S8001")
    If StrPtr(varAnw) = 0 Then Exit Sub
    If varAnw = "" Then MsgBox "Значение некорректное - до свидания!": Exit Sub
    Set RgAll = shtThis.Range("A2:E" & shtThis.Cells(Rows.Count, "E").End(xlUp).Row)
    rngNew.Value = RgAll.Rows(1).Offset(-1).Value
        For Each rngOld In RgAll.Cells
            If rngOld.Value Like varAnw Then
            Set rngNew = rngNew.Offset(1) 'смещение на 1 строку
            rngNew.Value = Intersect(RgAll, rngOld.EntireRow).Value
            End If
        Next rngOld
End Sub
 
 
 
#8
02.05.2024 08:18:21
Цитата
написал:
For i = 2 To UBound(Ar1): For j = 1 To UBound(Ar1, 2)
Евгений, спасибо большое за помощь с написанием кода и уделённое время.
К сожалению, код отрабатывает только на значении S8001. А при вводе слова "Казань" или части кода "SC101" всё равно копируются значения для "S8001".
Также, если вам не трудно можно вас попросить написать комментарии к процессам, операторам и переменным, чтобы я смог учиться гляда на ваш код.
Заранее спасибо!
 
 
 
#9
02.05.2024 08:51:13
Цитата
написал:
Set RgAll = shtThis.Range("A2:E" & shtThis.Cells(Rows.Count, "E").End(xlUp).Row)
Евгений, огромное спасибо за ещё один код.
Я проверил его работу и хотел уточнить, а почему поиск работает только по значениям, которые находятся в столбце D "Код подразделения".
Возможно, я ошибаюсь, но мы закладываем диапазон для поиска с A2 до последней ячейки в столбце "E".
При варианте вводе слова "Отгрузка" макрос должен найти 50 значений и скопировать 50 строк в rngNew, или я ошибаюсь?
Заранее спасибо за ваш ответ.
 
 
 
#10
03.05.2024 23:35:40
User2616
Цитата
При варианте вводе слова "Отгрузка" макрос должен найти 50 значений и скопировать 50 строк в rngNew, или я ошибаюсь?
Поиск может быть на полное соответствие или содержит а также с учетом регистра и без учета регистра. (Это также как в стандартном инструменте поиск и в автофильтре) 1 вариант поиск содержит 2 вариант на полное соответствие. Оба варианта с учетом регистра.
 
 
 
Страницы: 1
Наверх