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

Вход

Регистрация

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

 

= Мир MS Excel/Поиск по условию и добавление данных из 2 листов - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_, DrMini  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Поиск по условию и добавление данных из 2 листов (Макросы/Sub)
Поиск по условию и добавление данных из 2 листов
Ponka Дата: Вторник, 03.06.2014, 12:37 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Здравствуйте, ГУРУ Excel!!!
Помогите написать макрос.
Есть три листа
На листе "свод" данные по которому осуществляется поиск, столбец А
На "лист1" и "лист2" соответствующие значения в столбце А и данными в столбце С
Необходимо по листу "свод" найти соответствующие данным в "лист1" и "лист2" и добавить в Свод в столбец D данные из столбцов С
Не могу сообразить как сделать так, чтоб макрос не найдя совпадений в "лист1" стал их искать во втором листе и добавлял значения друг под другом и наоборот
К сообщению приложен файл: _03.06.14.xlsx (9.4 Kb)
 
Ответить
СообщениеЗдравствуйте, ГУРУ Excel!!!
Помогите написать макрос.
Есть три листа
На листе "свод" данные по которому осуществляется поиск, столбец А
На "лист1" и "лист2" соответствующие значения в столбце А и данными в столбце С
Необходимо по листу "свод" найти соответствующие данным в "лист1" и "лист2" и добавить в Свод в столбец D данные из столбцов С
Не могу сообразить как сделать так, чтоб макрос не найдя совпадений в "лист1" стал их искать во втором листе и добавлял значения друг под другом и наоборот
Автор - Ponka
Дата добавления - 03.06.2014 в 12:37
Ponka Дата: Среда, 04.06.2014, 12:14 | Сообщение № 2
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Вот мои несчастные попытки!
Но это с помощью функции впр, хотелось бы упростить, может как то поиском!
Подскажите, пожалуйста, или дайте хотя бы направление.

[vba]
Код
Worksheets("свод").Range("F1").EntireColumn.Insert ' выделяем лист "база столбец F и добавляет перед ним еще один столбец"
Worksheets("свод").Range("F1").EntireColumn.Insert ' выделяем лист "база столбец F и добавляет перед ним еще один столбец"
Sheets("свод").Select
Ri_ = Range("B" & Rows.Count).End(xlUp).Row ' определяем последнее значение с данными по столбцу B
Range("F3:F3").Activate 'выбираем активную ячейку
ActiveCell.FormulaR1C1 = "=VLOOKUP(C[-4],лист1!C[-5]:C[-3],3,0)"
Selection.AutoFill Destination:=Range("F3:F" & Ri_)
Range("G3:G3").Activate
ActiveCell.FormulaR1C1 = "=VLOOKUP(C[-5],лист2!C[-6]:C[-2],5,0)"
Selection.AutoFill Destination:=Range("G3:G" & Ri_)
Columns("F:G").Select ' выделяем столбецы F,G со значениями
Selection.Copy 'копируем выделенное
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False 'столбец с выделенными формулами превращаем в данные
Worksheets("свод").Range("F:G").Replace What:="#N/A", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("H3").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]=0,RC[-2],RC[-1])"
Selection.AutoFill Destination:=Range("H3:H686")
Columns("H:H").Select ' выделяем столбец Н со значениями
Selection.Copy 'копируем выделенное
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False 'столбец с выделенными формулами превращаем в данные
Worksheets("свод").Columns("F:G").Delete
[/vba]
К сообщению приложен файл: _03.06.14.xlsm (21.8 Kb)
 
Ответить
СообщениеВот мои несчастные попытки!
Но это с помощью функции впр, хотелось бы упростить, может как то поиском!
Подскажите, пожалуйста, или дайте хотя бы направление.

[vba]
Код
Worksheets("свод").Range("F1").EntireColumn.Insert ' выделяем лист "база столбец F и добавляет перед ним еще один столбец"
Worksheets("свод").Range("F1").EntireColumn.Insert ' выделяем лист "база столбец F и добавляет перед ним еще один столбец"
Sheets("свод").Select
Ri_ = Range("B" & Rows.Count).End(xlUp).Row ' определяем последнее значение с данными по столбцу B
Range("F3:F3").Activate 'выбираем активную ячейку
ActiveCell.FormulaR1C1 = "=VLOOKUP(C[-4],лист1!C[-5]:C[-3],3,0)"
Selection.AutoFill Destination:=Range("F3:F" & Ri_)
Range("G3:G3").Activate
ActiveCell.FormulaR1C1 = "=VLOOKUP(C[-5],лист2!C[-6]:C[-2],5,0)"
Selection.AutoFill Destination:=Range("G3:G" & Ri_)
Columns("F:G").Select ' выделяем столбецы F,G со значениями
Selection.Copy 'копируем выделенное
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False 'столбец с выделенными формулами превращаем в данные
Worksheets("свод").Range("F:G").Replace What:="#N/A", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("H3").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-1]=0,RC[-2],RC[-1])"
Selection.AutoFill Destination:=Range("H3:H686")
Columns("H:H").Select ' выделяем столбец Н со значениями
Selection.Copy 'копируем выделенное
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False 'столбец с выделенными формулами превращаем в данные
Worksheets("свод").Columns("F:G").Delete
[/vba]
Автор - Ponka
Дата добавления - 04.06.2014 в 12:14
krosav4ig Дата: Четверг, 05.06.2014, 02:44 | Сообщение № 3
Группа: Друзья
Ранг: Старожил
Сообщений: 2348
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
..
К сообщению приложен файл: 2_03.06.14.xlsm (20.4 Kb)

email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460

Сообщение отредактировал krosav4ig - Четверг, 05.06.2014, 03:05
 
Ответить
Сообщение..
Автор - krosav4ig
Дата добавления - 05.06.2014 в 02:44
Ponka Дата: Четверг, 05.06.2014, 16:48 | Сообщение № 4
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
я долго долго мучилась
и не без помощи получилось вот так:
может кому то поможет

Sub sdf()

With Sheets("свод")
i = 3
While .Cells(i, 2) <> ""
doc = .Cells(i, 2)
j = 2
f = True
Do
If Sheets("лист1").Cells(j, 1) = doc Then
.Cells(i, 6) = Sheets("лист1").Cells(j, 3)
f = False
Exit Do
End If
j = j + 1
Loop Until Sheets("лист1").Cells(j, 1) = ""
If f Then
k = 2
Do
If Sheets("лист2").Cells(k, 1) = doc Then
.Cells(i, 6) = Sheets("лист2").Cells(k, 5)
Exit Do
End If
k = k + 1
Loop Until Sheets("лист2").Cells(k, 1) = ""
End If
i = i + 1
Wend
End With
End Sub
К сообщению приложен файл: 05.06.2014.xlsm (18.6 Kb)
 
Ответить
Сообщениея долго долго мучилась
и не без помощи получилось вот так:
может кому то поможет

Sub sdf()

With Sheets("свод")
i = 3
While .Cells(i, 2) <> ""
doc = .Cells(i, 2)
j = 2
f = True
Do
If Sheets("лист1").Cells(j, 1) = doc Then
.Cells(i, 6) = Sheets("лист1").Cells(j, 3)
f = False
Exit Do
End If
j = j + 1
Loop Until Sheets("лист1").Cells(j, 1) = ""
If f Then
k = 2
Do
If Sheets("лист2").Cells(k, 1) = doc Then
.Cells(i, 6) = Sheets("лист2").Cells(k, 5)
Exit Do
End If
k = k + 1
Loop Until Sheets("лист2").Cells(k, 1) = ""
End If
i = i + 1
Wend
End With
End Sub
Автор - Ponka
Дата добавления - 05.06.2014 в 16:48
Ponka Дата: Четверг, 05.06.2014, 16:50 | Сообщение № 5
Группа: Пользователи
Ранг: Прохожий
Сообщений: 7
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
krosav4ig,
Вам огромное спасибо что откликнулись!
 
Ответить
Сообщениеkrosav4ig,
Вам огромное спасибо что откликнулись!
Автор - Ponka
Дата добавления - 05.06.2014 в 16:50
Hugo Дата: Четверг, 05.06.2014, 18:02 | Сообщение № 6
Группа: Друзья
Ранг: Участник клуба
Сообщений: 3854
Репутация: 814 ±
Замечаний: 0% ±

365
krosav4ig, интересное решение. Но на словаре было бы быстрее на больших объёмах.
А зачем тут буфер использовать? Вполне можно без него:
[vba]
Код
Sub sdf()
     Dim arr(), result(), i%, j&, r&
     Dim sh As Worksheet, rng As Range
     Set sh = ThisWorkbook.Worksheets("Свод")
     r = sh.Cells(sh.Rows.Count, 2).End(xlUp).Row
     arr() = sh.Range("B2:B" & r)
     ReDim result(1 To UBound(arr), 1 To 1)
     For i = 1 To 2
         With ThisWorkbook.Worksheets("Лист" & i).Columns(1)
             For j = 1 To UBound(arr)
                 Set rng = .Find(arr(j, 1), , xlValues, xlWhole)
                 If Not rng Is Nothing Then
                     result(j, 1) = result(j, 1) + rng.Offset(0, 2)
                 End If
             Next
         End With
     Next
     sh.Range("D2").Resize(UBound(arr), 1) = result
     Erase arr, result
End Sub
[/vba]
 
Ответить
Сообщениеkrosav4ig, интересное решение. Но на словаре было бы быстрее на больших объёмах.
А зачем тут буфер использовать? Вполне можно без него:
[vba]
Код
Sub sdf()
     Dim arr(), result(), i%, j&, r&
     Dim sh As Worksheet, rng As Range
     Set sh = ThisWorkbook.Worksheets("Свод")
     r = sh.Cells(sh.Rows.Count, 2).End(xlUp).Row
     arr() = sh.Range("B2:B" & r)
     ReDim result(1 To UBound(arr), 1 To 1)
     For i = 1 To 2
         With ThisWorkbook.Worksheets("Лист" & i).Columns(1)
             For j = 1 To UBound(arr)
                 Set rng = .Find(arr(j, 1), , xlValues, xlWhole)
                 If Not rng Is Nothing Then
                     result(j, 1) = result(j, 1) + rng.Offset(0, 2)
                 End If
             Next
         End With
     Next
     sh.Range("D2").Resize(UBound(arr), 1) = result
     Erase arr, result
End Sub
[/vba]
Автор - Hugo
Дата добавления - 05.06.2014 в 18:02
krosav4ig Дата: Пятница, 06.06.2014, 15:33 | Сообщение № 7
Группа: Друзья
Ранг: Старожил
Сообщений: 2348
Репутация: 997 ±
Замечаний: 0% ±

Excel 2007,2010,2013
Hugo, спасибо :)
Цитата Hugo, 05.06.2014 в 18:02, в сообщении № 6
А зачем тут буфер использовать
Да просто так, захотелось :)
 
Ответить
СообщениеHugo, спасибо :)
Цитата Hugo, 05.06.2014 в 18:02, в сообщении № 6
А зачем тут буфер использовать
Да просто так, захотелось :)
Автор - krosav4ig
Дата добавления - 06.06.2014 в 15:33
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Поиск по условию и добавление данных из 2 листов (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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