Добрый день, Помогите написать макрос. Он должен искать по листу1 значение из ячейки А1 и при нахождении копировать эти данные, данные соседней слева ячейки и данные 1 ячейки в строке на 2 лист соответственно в столбцы А,В,С. Значений будет много, нужно чтобы вставлял по порядку.
Добрый день, Помогите написать макрос. Он должен искать по листу1 значение из ячейки А1 и при нахождении копировать эти данные, данные соседней слева ячейки и данные 1 ячейки в строке на 2 лист соответственно в столбцы А,В,С. Значений будет много, нужно чтобы вставлял по порядку.konstantinp
Вставил руками во второй лист что должно получиться. То есть ввожу в ячейку А1 дату, макрос должен искать все такие же даты и копировать из этой строки данные и переносить по порядку на лист2.
Вставил руками во второй лист что должно получиться. То есть ввожу в ячейку А1 дату, макрос должен искать все такие же даты и копировать из этой строки данные и переносить по порядку на лист2.konstantinp
У меня какой-то такой макрик получился (если я правильно понял задание): [vba]
Code
Sub findFromA1()
Dim c As Range Dim d As Range Dim firstAddress As String
With Sheets(1).Range(Columns(2), Columns(Columns.Count)) Set c = .Find([A1], LookIn:=xlValues) If Not c Is Nothing Then firstAddress = c.Address Do Set d = [Лист2].Range("A" & Rows.Count).End(xlUp).Offset(1) d.Offset(0, 0) = c.Parent.Cells(c.Row, 1) d.Offset(0, 1) = c.Offset(0, -1) d.Offset(0, 2) = c Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address <> firstAddress End If End With
End Sub
[/vba]
У меня какой-то такой макрик получился (если я правильно понял задание): [vba]
Code
Sub findFromA1()
Dim c As Range Dim d As Range Dim firstAddress As String
With Sheets(1).Range(Columns(2), Columns(Columns.Count)) Set c = .Find([A1], LookIn:=xlValues) If Not c Is Nothing Then firstAddress = c.Address Do Set d = [Лист2].Range("A" & Rows.Count).End(xlUp).Offset(1) d.Offset(0, 0) = c.Parent.Cells(c.Row, 1) d.Offset(0, 1) = c.Offset(0, -1) d.Offset(0, 2) = c Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address <> firstAddress End If End With
_Boroda_, Это мой долбаный рабочий антивирус файлы отбивает с "кодами", остановить его не могу. Если не сложно, можно в архиве, пазязя) Gustav, А можете код расписать?
_Boroda_, Это мой долбаный рабочий антивирус файлы отбивает с "кодами", остановить его не могу. Если не сложно, можно в архиве, пазязя) Gustav, А можете код расписать?konstantinp
В смысле прокомментировать операторы? Сам цикл я, не мудрствуя лукаво, спёр из хелпа для Find (или FindNext). Можете нажать на них F1 и всё увидите сам. Цикл будет повторяться до тех пор пока не будет снова найдено самое первое значение (контролируется по совпадению адресов текущей и самой первой найденной ячеек) - тогда цикл прекратится. После нахождения очередного значения в цикле происходит заполнение очередной строки на Листе2. Область поиска на Листе1 - начиная со второй колонки (B) и до последней (в первой же колонке у нас само значение для поиска, а также другие заранее заготовленные строки).
Quote (konstantinp)
Gustav, А можете код расписать?
В смысле прокомментировать операторы? Сам цикл я, не мудрствуя лукаво, спёр из хелпа для Find (или FindNext). Можете нажать на них F1 и всё увидите сам. Цикл будет повторяться до тех пор пока не будет снова найдено самое первое значение (контролируется по совпадению адресов текущей и самой первой найденной ячеек) - тогда цикл прекратится. После нахождения очередного значения в цикле происходит заполнение очередной строки на Листе2. Область поиска на Листе1 - начиная со второй колонки (B) и до последней (в первой же колонке у нас само значение для поиска, а также другие заранее заготовленные строки).Gustav
А если "Тоже текст5" будет не в столбце"А", а в строке "1" над "Текст"? d.Offset(0, 0) = c.Parent.Cells(c.Row, 1) - как тут сделать не столбец, а верхнюю строку?
d.Offset(0, 0) = c.Parent.Cells(1, c.Column - 1)
Quote (konstantinp)
Да, и еще я вставляю в книгу, где много листов - выдает ошибку.
Наверное, тогда надо Sheets(1) заменить на ActiveSheet
Подозреваю также, что надо область поиска подкрутить. Как теперь надо? Всё, кроме первой строки? Или даже всё, кроме первой строки и первого столбца? Хорошо бы пример измененного файла...
P.S. Если кроме первой строки и первого столбца, то замените строку
With Sheets(1).Range(Columns(2), Columns(Columns.Count))
на
With ActiveSheet.Range(Cells(2, 2), Cells.SpecialCells(xlCellTypeLastCell))
Quote (konstantinp)
А если "Тоже текст5" будет не в столбце"А", а в строке "1" над "Текст"? d.Offset(0, 0) = c.Parent.Cells(c.Row, 1) - как тут сделать не столбец, а верхнюю строку?
d.Offset(0, 0) = c.Parent.Cells(1, c.Column - 1)
Quote (konstantinp)
Да, и еще я вставляю в книгу, где много листов - выдает ошибку.
Наверное, тогда надо Sheets(1) заменить на ActiveSheet
Подозреваю также, что надо область поиска подкрутить. Как теперь надо? Всё, кроме первой строки? Или даже всё, кроме первой строки и первого столбца? Хорошо бы пример измененного файла...
P.S. Если кроме первой строки и первого столбца, то замените строку
With Sheets(1).Range(Columns(2), Columns(Columns.Count))
на
With ActiveSheet.Range(Cells(2, 2), Cells.SpecialCells(xlCellTypeLastCell))Gustav
Поиск по всем, кроме Лист2, на который пишем: [vba]
Code
Sub findFromA1v2()
Dim wks As Worksheet Dim c As Range Dim d As Range Dim firstAddress As String
For Each wks In ThisWorkbook.Worksheets
If wks.Name <> "Лист2" Then
firstAddress = "" With wks.Range(wks.Cells(2, 2), wks.Cells.SpecialCells(xlCellTypeLastCell)) Set c = .Find(wks.Range("A1"), LookIn:=xlValues) If Not c Is Nothing Then firstAddress = c.Address Do Set d = [Лист2].Range("A" & Rows.Count).End(xlUp).Offset(1) d.Offset(0, 0) = wks.Cells(1, c.Column - 1) d.Offset(0, 1) = c.Offset(0, -1) d.Offset(0, 2) = c d.Offset(0, 3) = wks.Name 'для наглядности имя листа Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address <> firstAddress End If End With
End If
Next wks
End Sub
[/vba]
Quote (konstantinp)
А можно сделать, чтобы по всем листам искал?
Поиск по всем, кроме Лист2, на который пишем: [vba]
Code
Sub findFromA1v2()
Dim wks As Worksheet Dim c As Range Dim d As Range Dim firstAddress As String
For Each wks In ThisWorkbook.Worksheets
If wks.Name <> "Лист2" Then
firstAddress = "" With wks.Range(wks.Cells(2, 2), wks.Cells.SpecialCells(xlCellTypeLastCell)) Set c = .Find(wks.Range("A1"), LookIn:=xlValues) If Not c Is Nothing Then firstAddress = c.Address Do Set d = [Лист2].Range("A" & Rows.Count).End(xlUp).Offset(1) d.Offset(0, 0) = wks.Cells(1, c.Column - 1) d.Offset(0, 1) = c.Offset(0, -1) d.Offset(0, 2) = c d.Offset(0, 3) = wks.Name 'для наглядности имя листа Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address <> firstAddress End If End With
Gustav, Я бы тебе медаль вручил за терпение) Спасибо! А можешь еще помочь кое с чем? Эти данные (сформированные) нужно разослать адресатам по Outlook, где из получившихся данных в 1 столбце адреса?
Gustav, Я бы тебе медаль вручил за терпение) Спасибо! А можешь еще помочь кое с чем? Эти данные (сформированные) нужно разослать адресатам по Outlook, где из получившихся данных в 1 столбце адреса?konstantinp
А можешь еще помочь кое с чем? Эти данные (сформированные) нужно разослать адресатам по Outlook, где из получившихся данных в 1 столбце адреса?
Не, не могу. В Outlook'е рука не набита и модель ее объектную не очень знаю. Плюс, насколько смутно помню, там всякие рогатки безопасности всплывают при серийной отправке. Типа надо сидеть и на каждый адрес ОК кликать. Хотя может уже и не так сурово, давненько я с этим ковырялся.
Кинь предложение в раздел "Работа" или, может, тут кто из ребят заинтересуется, сделает.
Quote (konstantinp)
А можешь еще помочь кое с чем? Эти данные (сформированные) нужно разослать адресатам по Outlook, где из получившихся данных в 1 столбце адреса?
Не, не могу. В Outlook'е рука не набита и модель ее объектную не очень знаю. Плюс, насколько смутно помню, там всякие рогатки безопасности всплывают при серийной отправке. Типа надо сидеть и на каждый адрес ОК кликать. Хотя может уже и не так сурово, давненько я с этим ковырялся.
Кинь предложение в раздел "Работа" или, может, тут кто из ребят заинтересуется, сделает.Gustav
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
выполните замену из предыдущего сообщения (P.S.)
