Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > Microsoft Office и VBA программирование > Microsoft Office Excel
Регистрация

Восстановить пароль
Повторная активизация e-mail

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 20.09.2013, 12:43   #1
A_next
Новичок
Джуниор
 
Регистрация: 20.09.2013
Сообщений: 2
По умолчанию Проверка данных на совпадение

Ребят помогите необразованному
Надо в екселе проверить по столбцу номер телефона из списка на другой странице и при совпадении номера перенести СТРОКУ на отдельную страницу Заранее все благодарен за помощь!
A_next вне форума Ответить с цитированием
Старый 20.09.2013, 12:52   #2
VictorM
Старожил
 
Аватар для VictorM
 
Регистрация: 15.05.2008
Сообщений: 2,058
По умолчанию

Как-то нашел в инете, уже и не помню где, вот такой макрос
Код:
Private Sub MacrosSearch_Text()
    If ThisWorkbook.ProtectStructure = True Then
       MsgBox "Структура рабочей книги защищена", vbCritical, "Создание отчёта-нового листа невозможно"
       Exit Sub
    End If
    
    iText$ = "Яблоко" 'образец для поиска
    
    Dim iCell As Range
    Set iCell = Me.UsedRange.Find(What:=iText$, LookIn:=xlValues, LookAt:=xlPart)
    'Если необходимо использовать строгое соответствие, то замените константу xlPart на xlWhole
    
    If Not iCell Is Nothing Then
       Application.ScreenUpdating = False
       With Worksheets.Add(After:=Sheets(Sheets.Count))
            iAddress$ = iCell.Address
            Do
                 iRow& = iRow& + 1
                 iCell.EntireRow.Copy Destination:=.Rows(iRow&)
                 Set iCell = Me.UsedRange.FindNext(After:=iCell)
            Loop While Not iCell Is Nothing And iCell.Address <> iAddress$
       End With
       Application.ScreenUpdating = True
    End If
End Sub
К сожалению не знаю автора.
Работает отлично, уже много раз применял в разных вариантах.
"Дайте людям рыбы, и вы накормите их на весь день; научите их ловить рыбу - и вы накормите их на всю жизнь"
"Большое спасибо" - Z261597841314, R208907249777, U447361470499
VictorM вне форума Ответить с цитированием
Старый 26.09.2013, 08:22   #3
A_next
Новичок
Джуниор
 
Регистрация: 20.09.2013
Сообщений: 2
По умолчанию

Цитата:
Сообщение от A_next Посмотреть сообщение
Ребят помогите необразованному
Надо в екселе проверить по столбцу номер телефона из списка на другой странице и при совпадении номера перенести СТРОКУ на отдельную страницу Заранее все благодарен за помощь!
Что никто не сталкивался с подобным? или что то очень сложное я написал? В ехселе это реально сделать то хоть? Искал программы подобные , ничего не смог найти. Заранее благодарен всем за участие.
A_next вне форума Ответить с цитированием
Старый 26.09.2013, 08:55   #4
Serge_Bliznykov
Старожил
 
Регистрация: 09.01.2008
Сообщений: 26,229
По умолчанию

Цитата:
Что никто не сталкивался с подобным?
т.е. Вы пост #2 на этой странице от VictorM не заметили?
Serge_Bliznykov вне форума Ответить с цитированием
Старый 26.09.2013, 09:19   #5
SAS888
Старожил
 
Аватар для SAS888
 
Регистрация: 05.12.2007
Сообщений: 4,180
По умолчанию

Пусть исходные данные находятся в столбце "A" на листе "Data". Пусть список находится в столбце "A" на листе "List". Пусть требуется вывести совпадающие данные в столбец "A" на лист "Result" (который может и отсутствовать).
Можно так:
Код:
Sub Main()
    Dim i As Long, j As Long, a(), b(), c(), x
    Set x = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False: Application.DisplayAlerts = False
    With Sheets("Data"): a = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row).Value: End With
    With Sheets("List"): b = .Range("A1:A" & .Cells(Rows.Count, 1).End(xlUp).Row).Value: End With
    For i = 1 To UBound(b, 1)
        If Not x.Exists(b(i, 1)) Then x.Add b(i, 1), i
    Next
    ReDim c(1 To UBound(a, 1), 1 To 1): j = 0
    For i = 1 To UBound(a, 1)
        If x.Exists(a(i, 1)) Then
            j = j + 1: c(j, 1) = a(i, 1)
        End If
    Next
    On Error Resume Next: Sheets("Result").Delete: On Error GoTo 0
    Sheets.Add.Name = "Result"
    If j > 0 Then [A1].Resize(UBound(c, 1)).Value = c
End Sub
Чем шире угол зрения, тем он тупее.

Последний раз редактировалось SAS888; 26.09.2013 в 09:27.
SAS888 вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц



Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
RichEdit проверка на совпадение volod3000 Общие вопросы Delphi 2 09.12.2011 15:25
Проверка на совпадение записи в БД MS Access Lived08 БД в Delphi 2 23.05.2010 18:08
Проверка на совпадение записи Lokos БД в Delphi 4 29.04.2010 08:55
Проверка на совпадение записи Lokos БД в Delphi 0 29.04.2010 03:51
Проверка на совпадение. Firebird. artemavd БД в Delphi 6 18.03.2010 16:34