Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Поиск до последней заполненной ячейки и вывод номеров столбцов
 
#1
09.12.2021 13:09:20
Уважаемые форумчане, помогите, пожалуйста, адаптировать код под мои нужды. У самого ничего не получается.
Необходимо, чтобы поиск осуществлялся по строчке №6 до последней заполненной ячейки и выводил найденные значения в виде номера колонок, в которых они находятся. Поиск должен быть не точным (находить по части слова, например, ТОМСК, ТОМСКГАЗ, ЭНЕРГОТОМСК). Если это важно, то код будет находиться в одном файле (в юзерформе), а поиск осуществляться в другом. Большое спасибо!
P.S. Малые буквы - это комментарии, которые уже были в коде, когда я его нашел.
Большие - мои комментарии.
Код
Sub Poisk()Dim cell As Range,cellsDel As Range, cellAddress As String
With Workbooks("Книга1.xlsx").Sheets("Лист2").cells(6, Columns.Count).End(xlToLeft).Column.UsedRange ' ЗДЕСЬ, КАК Я ПОНИМАЮ, НУЖНО УКАЗАТЬ, ГДЕ ИСКАТЬ. УКАЗАЛ

' ЗДЕСЬ, ЧТО ИЩЕМ. УКАЗАЛ  Set cell = .Find(Workbooks("Книга1.xlsx").Sheets("Лист1").Range("H2")) 'ищем первую попавшуЮсяIf Not cell Is Nothing Then 'если нашлиSet cellsDel = cell.Resize(2) 'сохраняем в переменную, увеличенную до 2 строк (Resize(2)) 'МНЕ НИЧЕГО УВЕЛИЧИВАТЬ НЕ НАДО
cellAddress = cell.Address 'запоминаем адрес, потому что FindNext будет искать по кругу и ее надо будет остановить
Do
Set cell = .FindNext(cell) 'продолжаем поиск после ячейки cell
If Not cell Is Nothing Then Set cellsDel = Union(cellsDel, cell.Resize(2)) 'если нашли, то добавляем в cellsDel ЗДЕСЬ ТОЖЕ ДВОЙКА В КОНЦЕ СМУЩАЕТ - УВЕЛИЧИВАТЬ НИЧЕГО НЕ НУЖНО      'DoEvents 'эту штуку можно ставить на стадии отладки, чтоб можно остановить Do...Loop в случае косяка
Loop Until cellAddress = cell.Address 'если дошли до адреса который уже был, выпадаем из Do...Loop
cellsDel.EntireRow.Delete 'удаляем строки принадлежащие ячейкам в переменной cellsDel МНЕ НЕ НУЖНО УДАЛЯТЬ - 'НУЖНО НОМЕРА КОЛОНОК СО ВСЕМИ НАЙДЕННЫМИ ЗНАЧЕНИЯМИ ВЫСТРОИТЬ В СТОЛБИК НА ЛИСТЕ Workbooks("Книга1.xlsx").Sheets("Лист1"), НАЧИНАЯ С ЯЧЕЙКИ I1.
End If
End With
End sub
' КОД БУДЕТ НАХОДИТЬСЯ В КНИГЕ Книга2.xlsb
 
 
 
#2
09.12.2021 13:17:24
Platon,  а на чём проверять код тому, кто захочет Вам помочь?
 
 
 
#3
10.12.2021 08:44:49
Попробуйте так:
Код
Private Sub CommandButton1_Click()
    Dim c As Range
    Dim firstAddress As String
    Set Dict = CreateObject("Scripting.Dictionary")
    lc = Workbooks("П2.xlsx").Sheets("Лист2").Cells(6, Columns.Count).End(xlToLeft).Column
    With Workbooks("П2.xlsx").Sheets("Лист2").Range(Workbooks("П2.xlsx").Sheets("Лист2").Cells(6, 1), Workbooks("П2.xlsx").Sheets("Лист2").Cells(6, lc))
        Set c = .Find(TextBox1.Value, LookIn:=xlValues)
        If Not c Is Nothing Then
            firstAddress = c.Address
            Do
                Dict.Add c.Address, c.Value
                Set c = .FindNext(c)
            Loop While c.Address <> firstAddress
        End If
    End With
    If Dict.Count = 0 Then Exit Sub
    Workbooks("П2.xlsx").Sheets("Лист1").Range("A1").Resize(Dict.Count, 1) = WorksheetFunction.Transpose(Dict.Keys)
    Workbooks("П2.xlsx").Sheets("Лист1").Range("B1").Resize(Dict.Count, 1) = WorksheetFunction.Transpose(Dict.Items)
'    Unload UserForm1
End Sub


или так
Код
Private Sub CommandButton2_Click()
    Dim Arr1 As Variant, n As Integer
    Set Dict = CreateObject("Scripting.Dictionary")
    n = Workbooks("П2.xlsx").Sheets("Лист2").Cells(6, Columns.Count).End(xlToLeft).Column
    Arr1 = Workbooks("П2.xlsx").Sheets("Лист2").Range(Workbooks("П2.xlsx").Sheets("Лист2").Cells(6, 1), Workbooks("П2.xlsx").Sheets("Лист2").Cells(6, n))
    For n = 1 To UBound(Arr1, 2)
        If UCase(Arr1(1, n)) Like "*" & UCase(TextBox1.Value) & "*" Then Dict.Add Cells(6, n).Address, Arr1(1, n)
'        If InStr(UCase(Arr1(1, n)), UCase(TextBox1.Value)) > 0 Then Dict.Add Cells(6, n).Address, Arr1(1, n)
    Next
    If Dict.Count = 0 Then Exit Sub
    Workbooks("П2.xlsx").Sheets("Лист1").Range("A1").Resize(Dict.Count, 1) = WorksheetFunction.Transpose(Dict.Keys)
    Workbooks("П2.xlsx").Sheets("Лист1").Range("B1").Resize(Dict.Count, 1) = WorksheetFunction.Transpose(Dict.Items)
'    Unload UserForm1
End Sub


Или можно без UserForm
Код
Sub Макрос2()
    Dim Arr1 As Variant, n As Integer, a As String
    Set Dict = CreateObject("Scripting.Dictionary")
    n = Workbooks("П2.xlsx").Sheets("Лист2").Cells(6, Columns.Count).End(xlToLeft).Column
    Arr1 = Workbooks("П2.xlsx").Sheets("Лист2").Range(Workbooks("П2.xlsx").Sheets("Лист2").Cells(6, 1), Workbooks("П2.xlsx").Sheets("Лист2").Cells(6, n))
    a = InputBox("Введите слово")
    If a = "" Then Exit Sub
    For n = 1 To UBound(Arr1, 2)
        If UCase(Arr1(1, n)) Like "*" & UCase(a) & "*" Then Dict.Add Cells(6, n).Address, Arr1(1, n)
    Next
    If Dict.Count = 0 Then Exit Sub
    Workbooks("П2.xlsx").Sheets("Лист1").Range("A1").Resize(Dict.Count, 1) = WorksheetFunction.Transpose(Dict.Keys)
    Workbooks("П2.xlsx").Sheets("Лист1").Range("B1").Resize(Dict.Count, 1) = WorksheetFunction.Transpose(Dict.Items)
End Sub
Изменено: Msi2102 - 10.12.2021 09:07:59
 
 
 
Страницы: 1
Наверх