Форум программистов, компьютерный форум, киберфорум
VBA
Войти
Регистрация
Восстановить пароль
 
Рейтинг 4.82/11: Рейтинг темы: голосов - 11, средняя оценка - 4.82
0 / 0 / 0
Регистрация: 10.09.2013
Сообщений: 6
1

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

10.09.2013, 01:09. Показов 2138. Ответов 11
Метки нет (Все метки)

Добрый вечер! Идея такая! Есть Два столбца, Один большой, второй меньше, нужно найти значения из столбца 2 в столбце 1, удалить их оттуда и перенести на второй лист. Все это с помощью кнопки VBA.
Код нужен. Сможете помочь?
__________________
Помощь в написании контрольных, курсовых и дипломных работ здесь
0
Programming
Эксперт
94731 / 64177 / 26122
Регистрация: 12.04.2006
Сообщений: 116,782
10.09.2013, 01:09
Ответы с готовыми решениями:

Поиск строки и перенос двух соответствующих ей ячеек на другой лист
Подскажите пожалуйста каким образом реализовать вот такую вот скромную задачку. есть таблица в ней...

Перенос значений на другой лист по заданной дате
День добрый. Столкнулся с вопросом переноса данных из ячейки одного листа в ячейку на другой лист -...

Перенос значений на другой лист с поиском свободной строки
Здравствуйте. Прошу помощи. Нужно сделать перенос значений определенных ячеек на другой лист по...

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

11
4375 / 659 / 36
Регистрация: 17.01.2010
Сообщений: 2,134
10.09.2013, 10:33 2
Слово "схожих" ставит в тупик. Я понимаю как "похожих" - это так? Если да, то какие критерии схожести? И лучше Вам дать образец Ваших столбцов.
0
6856 / 2791 / 529
Регистрация: 19.10.2012
Сообщений: 8,520
10.09.2013, 11:09 3
Без примера и доп.информации делать бестолково. Т.к. не видны (не известны, нужны пояснения) многие мелочи:
1.насколько большие столбцы?
2.какие данные? (может там рисунки нужно сравнивать? или даты написанные как попало? или банальные пробелы раскиданы хаотичным образом?)
3.сколько экземпляров этих повторяющихся данных? что делать с повторами? а если вдруг будут? или точно не будут?
4.удалять только данные или строки целиком?
5.переносить все повторы или только по одному разу?
6.переносить только данные, или ячейки со всеми форматами?
7.а может там формулы?
8.или вообще отображаемые значения созданы форматом?
9.второй лист - он уже есть? что там?
10.где вообще эти два столбца? в каком виде? может там хаотичные объединения?
...
0
0 / 0 / 0
Регистрация: 10.09.2013
Сообщений: 6
11.09.2013, 20:17  [ТС] 4
1 столбец А, но теоретически может быть где угодно, в нем указано очень много номеров телефонов, примерно 1000, формат 79020001100. Во втором столбце С, черный список, немного номеров, штук 50, формат без семерки. Нужно найти номера из черного списка в первом столбце и перенести их на лист 2, просто пустой лист.
0
4375 / 659 / 36
Регистрация: 17.01.2010
Сообщений: 2,134
11.09.2013, 20:59 5
Рядом с черным списком, в соседнем ст., выдлелите диапазон ячеек от первого "черного" до последнего "черного".
Нажмите = . Дальше пишите countif( . Выделите весь ст. "А". Наберите на кл-ре ; . Выделите номер в черном списке слева от ячейки, в которую записываете формулу. Наберите на кл-ре ) . Нажмите комбинацию Cntr + Enter. Выберите фильтром которые не 0 и скопируйте куда хотите. И все. Все без точек.
0
0 / 0 / 0
Регистрация: 10.09.2013
Сообщений: 6
11.09.2013, 23:03  [ТС] 6
Цитата Сообщение от Igor_Tr Посмотреть сообщение
Рядом с черным списком, в соседнем ст., выдлелите диапазон ячеек от первого "черного" до последнего "черного".
Нажмите = . Дальше пишите countif( . Выделите весь ст. "А". Наберите на кл-ре ; . Выделите номер в черном списке слева от ячейки, в которую записываете формулу. Наберите на кл-ре ) . Нажмите комбинацию Cntr + Enter. Выберите фильтром которые не 0 и скопируйте куда хотите. И все. Все без точек.
Говорю же, все надо сделать с помощью кнопки VBA.
0
0 / 0 / 0
Регистрация: 10.09.2013
Сообщений: 6
11.09.2013, 23:08  [ТС] 7
Вот пример документа с макросом. Но не работает.
Вложения
Тип файла: xlsx пример.xlsm.xlsx (11.5 Кб, 15 просмотров)
0
0 / 0 / 0
Регистрация: 10.09.2013
Сообщений: 6
11.09.2013, 23:10  [ТС] 8
Sub Кнопка3_Щелчок()

Dim lLastRowA As Long
Dim lLastRowC As Long
Dim i As Long
Dim rFind As Excel.Range

Dim shSheet_1 As Excel.Worksheet
Dim shSheet_2 As Excel.Worksheet

Set shSheet_1 = Worksheets(1)
Set shSheet_2 = Worksheets(2)

lLastRowA = Cells(Rows.Count, "A").End(xlUp).Row
lLastRowC = Cells(Rows.Count, "H").End(xlUp).Row + 1
Application.ScreenUpdating = False
For i = 2 To lLastRowA Step 1
Set rFind = Columns("C").Find(What:=Cells(i, "A").Text, LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not rFind Is Nothing Then
Cells(lLastRowC, "H").Value = Cells(i, "A").Value
lLastRowC = lLastRowC + 1
End If

Next i

Application.ScreenUpdating = True

End Sub
0
4375 / 659 / 36
Регистрация: 17.01.2010
Сообщений: 2,134
11.09.2013, 23:14 9
Не понял. Это вам такое задание, или лично для себя?
0
0 / 0 / 0
Регистрация: 10.09.2013
Сообщений: 6
11.09.2013, 23:25  [ТС] 10
Цитата Сообщение от Igor_Tr Посмотреть сообщение
Не понял. Это вам такое задание, или лично для себя?
На работе дали задание, оно состоит из 6-ти задач. 4 я сделал.
0
4375 / 659 / 36
Регистрация: 17.01.2010
Сообщений: 2,134
11.09.2013, 23:25 11
Здесь формулой.
Вложения
Тип файла: xlsx WithFormula_пример.xlsm.xlsx (16.0 Кб, 31 просмотров)
0
4375 / 659 / 36
Регистрация: 17.01.2010
Сообщений: 2,134
12.09.2013, 14:42 12
Копируете код в обычный модуль Вашей книги. Правой кнопкой мыши на Вашей кнопке на листе. Там будет что-то "Присвоить макрос". Выбираете "Эта Книга", указываете макрос "BlackInWhite".
Сделал через массивы (не знаю, как Вам нужно). Результаты - в массиве arrR. Выкладываются на этом же листе. Если надо на другом - точно так, только это .[h2].Resize(UBound(arrR), 1).Value = arrR удалите оттуда, где оно теперь, и вставите, после End With, это:
Visual Basic
1
2
3
With sheets("[какое-то имя Вашего листа]")
   .[a2].Resize(UBound(arrR), 1).Value = arrR
end with
И все.
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub BlackInWhite()
Dim arrW(), arrB(), arrR(), i&, j&, c&
   With ActiveSheet
      arrW = .Columns("A:A").SpecialCells(xlCellTypeConstants, 1).Value
      arrB = .Columns("C:C").SpecialCells(xlCellTypeConstants, 1).Value
      ReDim arrR(1 To UBound(arrB), 1 To 1):   c = 0
         For i = LBound(arrB, 1) To UBound(arrB, 1)
            For j = LBound(arrW, 1) To UBound(arrW, 1)
               If "*" & CStr(arrW(j, 1)) Like "*" & CStr(arrB(i, 1)) Then
                  c = c + 1: arrR(c, 1) = arrW(j, 1): Exit For
               End If
            Next 'j
         Next 'i
      Application.ScreenUpdating = False
      .[h2].Resize(UBound(arrR), 1).Value = arrR
      Application.ScreenUpdating = True
   End With
End Sub


Добавлено через 3 часа 54 минуты
И здесь. Подправил немного Ваш код, если нужно через Find.
Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub Кнопка3_Щелчок()
Dim shSheet_1 As Excel.Worksheet, shSheet_2 As Excel.Worksheet
Dim rFind As Excel.Range, cC As Range, mARR(), i&
   Set shSheet_1 = Sheets("Лист1"):  Set shSheet_2 = Worksheets("Лист2")
   With shSheet_1
      ReDim mARR(1 To .Columns("c:c").SpecialCells(xlCellTypeConstants, 1).Count, 1 To 1)
      For Each cC In .Columns("c:c").SpecialCells(xlCellTypeConstants, 1).Cells
         Set rFind = .Columns("a:a").Find(cC.Value, , , xlPart, , False)
            If Not rFind Is Nothing Then i = i + 1:  mARR(i, 1) = rFind.Value
      Next
   End With
   With shSheet_2
      .Cells.Delete: .[a2].Resize(UBound(mARR, 1), 1).Value = mARR: .Columns.AutoFit
   End With
End Sub
0
IT_Exp
Эксперт
87844 / 49110 / 22898
Регистрация: 17.06.2006
Сообщений: 92,604
12.09.2013, 14:42

Перенос значений из отдельного листа Эксель в другой лист на основании выбранного значения по столбцу
Коллеги, прошу помощи! Есть основной лист в Эксель, называется потребность в ТМЦ. Данная форма...

Перенос строки с данными на другой лист и с дальнейшим удалением всей строки с первого листа
Добрый день! Помогите решить задачку, а именно на листе 1 есть таблица с данными: A-Дата, ...

Поиск заданного значения в нескольких листах и при нахождении перенос значений в итоговый лист
Боссу на работе нужно автоматизировать поиск в таблицах excel... Есть отдельный файл excel где...

Сравнение двух столбцов Excel и вывод на другой лист общих значений
Доброго времени суток. Встала острая необходимость в следующем: на листе "Замечания" есть...

Поиск на нескольких листах определенных значений и подтягивание найденных строк в другой лист
Здравствуйте. Не могу сам справиться со следующей задачей, поэтому прошу помощи. Есть файл...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
12
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2021, vBulletin Solutions, Inc.