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

Макрос для копирования информации с одного листа на другой по определенным условиям

31.05.2019, 13:30. Показов 31027. Ответов 23
Метки нет (Все метки)

Доброго времени суток, Гуру excel!!!

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

Файл с примером прилагаю в нем все цветами выделено что копировать и куда вставлять.

заранее спасибо!!!
0

Помощь в написании контрольных, курсовых и дипломных работ здесь.

Лучшие ответы (1)
Programming
Эксперт
94731 / 64177 / 26122
Регистрация: 12.04.2006
Сообщений: 116,782
31.05.2019, 13:30
Ответы с готовыми решениями:

Выборка из одного листа на другой по определенным условиям
Здравствуйте, помогите пожалуйста сделать выборку данных из одного листа на другой по определенным...

Макрос копирования одного диапазона с каждого листа книги в другой файл
Доброго времени суток, уважаемые форумчане! очень срочно нужна ваша помощь с небольшим макросом....

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

Макрос для выборочного переноса из одного листа в другой
Здраствуйте! Так уж сложилось, что я не владею языками (программирования), но хорошо разбираюсь в...

23
365 / 263 / 93
Регистрация: 18.11.2015
Сообщений: 974
31.05.2019, 13:31 2
А файл не приложили )
0
0 / 0 / 0
Регистрация: 02.12.2018
Сообщений: 94
31.05.2019, 13:32  [ТС] 3
ArtNord, сейчас минутку

вот файл
0
Вложения
Тип файла: xlsx Книга2.xlsx (35.0 Кб, 246 просмотров)
365 / 263 / 93
Регистрация: 18.11.2015
Сообщений: 974
31.05.2019, 13:43 4
Да, вижу, а что куда и по какому условию.
Все увидел внизу
0
0 / 0 / 0
Регистрация: 02.12.2018
Сообщений: 94
31.05.2019, 13:45  [ТС] 5
то что желтым выделено это условия, а синим это нужно перенести на лист 2
0
365 / 263 / 93
Регистрация: 18.11.2015
Сообщений: 974
31.05.2019, 14:07 6
Лучший ответ Сообщение было отмечено Александр_80 как решение

Решение

Проверьте
1
Вложения
Тип файла: 7z Копирование.7z (43.2 Кб, 303 просмотров)
365 / 263 / 93
Регистрация: 18.11.2015
Сообщений: 974
31.05.2019, 14:08 7
Александр_80, проверьте
0
0 / 0 / 0
Регистрация: 02.12.2018
Сообщений: 94
31.05.2019, 14:21  [ТС] 8
ArtNord, ДА ВСЕ РАБОТАЕТ ЭТО ПРОСТО МАГИЯ КАКАЯ ТО , ВОТ ТОЛЬКО Я ЗАБЫЛ УКАЗАТЬ НА КОЛОНКУ ДЮЙМЫ, МОЖНО ИХ ТОЖЕ КОПИРОВАТЬ? ПО ТЕМ ЖЕ УСЛОВИЯМ
0
365 / 263 / 93
Регистрация: 18.11.2015
Сообщений: 974
31.05.2019, 14:25 9
Добавил
1
Вложения
Тип файла: 7z Копирование.7z (43.5 Кб, 198 просмотров)
0 / 0 / 0
Регистрация: 02.12.2018
Сообщений: 94
31.05.2019, 14:46  [ТС] 10
ArtNord, Вы просто супер!!!! Спасибо огромное вам!!!!! Еще одна просьба, вы не могли бы разъяснить по вашему макросу, что какая команда делает?
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub Копирование()
AllRecs = Application.WorksheetFunction.CountA(Sheets("1").Range("B:B"))
cAllRecs = Application.WorksheetFunction.CountA(Sheets("2").Range("B:B"))
    For CurRec = 2 To AllRecs
    AllCrit = Sheets("1").Cells(CurRec, 2) & "_" & Sheets("1").Cells(CurRec, 3) & "_" & Sheets("1").Cells(CurRec, 8)
 
        For cRecs = 2 To cAllRecs
            CheckKrit = Sheets("2").Cells(cRecs, 2) & "_" & Sheets("2").Cells(cRecs, 3) & "_" & Sheets("2").Cells(cRecs, 19)
            If AllCrit = CheckKrit Then
            Sheets("2").Cells(cRecs, 27) = Sheets("1").Cells(CurRec, 11)
            Sheets("2").Cells(cRecs, 17) = Sheets("1").Cells(CurRec, 12)
            Sheets("2").Cells(cRecs, 18) = Sheets("1").Cells(CurRec, 13)
            Sheets("2").Cells(cRecs, 30) = Sheets("1").Cells(CurRec, 27)
            Sheets("2").Cells(cRecs, 29) = Sheets("1").Cells(CurRec, 30)
            Sheets("2").Cells(cRecs, 28) = Sheets("1").Cells(CurRec, 6)
            End If
        Next cRecs
    Next CurRec
End Sub
0
365 / 263 / 93
Регистрация: 18.11.2015
Сообщений: 974
31.05.2019, 14:57 11
Спасибо за оценку!
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Sub Копирование()
AllRecs = Application.WorksheetFunction.CountA(Sheets("1").Range("B:B")) ' Получение количества строк на листе 1 (подсчет значений в столбце B)
cAllRecs = Application.WorksheetFunction.CountA(Sheets("2").Range("B:B")) 'Аналогично для листа 2
For CurRec = 2 To AllRecs ' Начало цикла для Листа 1
AllCrit = Sheets("1").Cells(CurRec, 2) & "_" & Sheets("1").Cells(CurRec, 3) & "_" & Sheets("1").Cells(CurRec, 8) ' объединение 'всех критериев на Листе 1 в одну переменную
' Теперь эту "сумму критериев" ищем в Листе 2
For cRecs = 2 To cAllRecs ' Начало цикла для Листа 2
'Пробегаемся циклом по всем строкам Листа 2 сверяя сумму критериев на каждой строке с имеющейся суммой критериев
CheckKrit = Sheets("2").Cells(cRecs, 2) & "_" & Sheets("2").Cells(cRecs, 3) & "_" & Sheets("2").Cells(cRecs, 19) '  объединение 'всех критериев на Листе 2 в одну переменную
If AllCrit = CheckKrit Then 'сверка критериев если Они равны то:
'в этой строке указанным ячейкам присвоить значения из листа 1
Sheets("2").Cells(cRecs, 27) = Sheets("1").Cells(CurRec, 11) 
Sheets("2").Cells(cRecs, 17) = Sheets("1").Cells(CurRec, 12)
Sheets("2").Cells(cRecs, 18) = Sheets("1").Cells(CurRec, 13)
Sheets("2").Cells(cRecs, 30) = Sheets("1").Cells(CurRec, 27)
Sheets("2").Cells(cRecs, 29) = Sheets("1").Cells(CurRec, 30)
Sheets("2").Cells(cRecs, 28) = Sheets("1").Cells(CurRec, 6)
End If 'конец условия
Next cRecs 'следующая строка на Листе2
'После  окончания проверки на Листе 2 возвращаемся на Лист 1 за следующей суммой критериев:
Next CurRec
End Sub
1
0 / 0 / 0
Регистрация: 02.12.2018
Сообщений: 94
31.05.2019, 15:01  [ТС] 12
ArtNord, вам спасибо за помощь!!! на самом деле в этой таблице более 50000 строк и она с каждым днем становится больше. Макрос будет работать на все эти строки?
0
365 / 263 / 93
Регистрация: 18.11.2015
Сообщений: 974
31.05.2019, 15:01 13
Visual Basic
1
2
3
4
Next CurRec
'Здесь можно добавить вывод сообщения об окончании работы макроса:
msgbox("Готово!")
End Sub
Да, вот эта строчка как раз и опреляет сколько сейчас записей:
Visual Basic
1
cAllRecs = Application.WorksheetFunction.CountA(Sheets("2").Range("B:B"))
1
0 / 0 / 0
Регистрация: 02.12.2018
Сообщений: 94
31.05.2019, 15:04  [ТС] 14
ArtNord, а если копировать нужно не на лист 2 а на другой лист который находится в другой книге, что нужно сделать?
0
365 / 263 / 93
Регистрация: 18.11.2015
Сообщений: 974
31.05.2019, 15:06 15
Если книга эта открыта то:
Visual Basic
1
Workbooks("Название книги.xls").Sheets("Название листа").Cells(cRecs, 27) = Sheets("1").Cells(CurRec, 11)
0
0 / 0 / 0
Регистрация: 02.12.2018
Сообщений: 94
31.05.2019, 15:12  [ТС] 16
простите меня я такой овощь в этом деле, я не пойму куда мне нужно эту строчку вставить?
0
365 / 263 / 93
Регистрация: 18.11.2015
Сообщений: 974
31.05.2019, 15:15 17
Где присваиваете значения:
В каждой строке вида:
Visual Basic
1
Sheets("2").Cells(cRecs, 27) = Sheets("1").Cells(CurRec, 11)
Заменить на:
Visual Basic
1
Workbooks("Название книги.xls").Sheets("Название листа").Cells(cRecs, 27) = Sheets("1").Cells(CurRec, 11)
Добавлено через 1 минуту
Visual Basic
1
2
3
4
5
Workbooks("Название книги.xls").Sheets("Название листа").Cells(cRecs, 27) = Sheets("1").Cells(CurRec, 11) 
Workbooks("Название книги.xls").Sheets("Название листа").Cells(cRecs, 17) = Sheets("1").Cells(CurRec, 12)
Workbooks("Название книги.xls").Sheets("Название листа").Cells(cRecs, 18) = Sheets("1").Cells(CurRec, 13)
Workbooks("Название книги.xls").Sheets("Название листа").Cells(cRecs, 30) = Sheets("1").Cells(CurRec, 27)
Workbooks("Название книги.xls").Sheets("Название листа").Cells(cRecs, 28) = Sheets("1").Cells(CurRec, 6)
0
0 / 0 / 0
Регистрация: 02.12.2018
Сообщений: 94
31.05.2019, 15:16  [ТС] 18
ArtNord, Вы просто супер!!!! Я если честно даже не ожидал, что мне так сразу тут помогут!!! Дай вам бог здоровья!!!
0
365 / 263 / 93
Регистрация: 18.11.2015
Сообщений: 974
31.05.2019, 15:17 19
Спасибо! Взаимно! Просто коротаю время до конца рабочего дня ))))
0
0 / 0 / 0
Регистрация: 02.12.2018
Сообщений: 94
31.05.2019, 15:23  [ТС] 20
ArtNord, нет не просто коротаете, вы людям помогаете!!!! Еще раз огромное спасибо ВАМ!!!!

Добавлено через 4 минуты
ArtNord, вы не подскажете, можно самому так научиться макросы писать, если да то где?
0
IT_Exp
Эксперт
87844 / 49110 / 22898
Регистрация: 17.06.2006
Сообщений: 92,604
31.05.2019, 15:23

Макрос для переноса выделенных ячеек из одного листа документа в другой
Добрый день. Буду признателен тем, кто сможет оказать мне помощь в следующем вопросе. В...

Как скопировать значения ячеек с одного листа на другой с определенным интервалом
Мне нужно с листа "Февраль 2016" на лист "Производительность" перенести данные. С листа "Февраль...

Данные, соответствующие определённым значениям, перенести с одного листа на другой, на аналогичные значения
Задача такая: есть два файла xls. В Первом (исходном) файле: есть номера статей (допустим, от 1 до...

Макрос для переноса (с удалением) данных с одного листа на другой при появлении дополнительных данных в ячейке
Уважаемые форумчане, доброго дня. Прошу помочь по следующему вопросу: Во вложении файл Excel,...

Фиксирование информации с одного листа и запись на другой
dopustim na pervom liste kotoriy nazivaetsya muj imya familiya god rojdeniya na vtorom liste...

Перенос с одного листа на другой информации по условию
Подскажите пожалуйста, что-то я ..., необходимо перенести с одного листа (Лист1) на другой (Лист2)...


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

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

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