Макрос для excel для копирования данных с листа - Word и Excel

How to copy and paste data using a Macro in Excel. I’ll show you multiple ways to do this, including across worksheets and workbooks.

Sections:

Simple Copy/Paste

Copy Entire Range

Copy between Worksheets

Copy between Workbooks

Notes

Simple Copy/Paste

Range("A1").Copy Range("B1")

This copies cell A1 to cell B1.

Range(«A1»).Copy is the part that copies the cell.

Range(«B1») is the cell where the data will be copied.

This is a simple one line piece of code and it’s very easy to use.

Notice that there is a space between these two parts of the code.

Copy Entire Range

Range("A1:A5").Copy Range("B1:B5")

Range(«A1:A5»).Copy is the part that copies the range.

Range(«B1:B5») is the range where the data will be copied.

You can also write it like this:

Range("A1:A5").Copy Range("B1")

Notice that the range to where you will copy the data has only a reference to cell B1.

You only have to reference the very first cell to which the range will be copied and the entire range will copy in the cells below there.

NOTE: if you do it like this, you may end up overwriting data and Excel will not give you a warning about this; the data will simply be filled down as far as it needs to go to copy the first range.

Copy between Worksheets

Sheets("Sheet1").Range("A1").Copy Sheets("Sheet2").Range("B1")

This follows the same pattern as the above examples except that we need to tell the macro from which sheet we want to get the data and to which sheet we want to copy the data.

Sheets(«Sheet1»). is placed in front of the first range and that means to get the data from Sheet1, which is the name of a worksheet in the workbook.

Sheets(«Sheet2»). is placed in front of the range to which we want to copy the data and Sheet2 is the name of the worksheet where the data will be copied.

Copy between Workbooks

Workbooks("Copy and Paste Data using Macro VBA in Excel.xlsm").Sheets("Sheet1").Range("A1").Copy Workbooks("Copy and Paste Data using Macro VBA in Excel.xlsm").Sheets("Sheet3").Range("A1")

Here, we follow the above examples and, this time, add a reference to the workbooks from which we want to get the data and to which we want to place the data.

Workbooks(«Copy and Paste Data using Macro VBA in Excel.xlsm»). is the code that says in which workbook we want to place the data. Copy and Paste Data using Macro VBA in Excel.xlsm is the name of the workbook. In this example I used this for both parts, the workbook from which the data comes and where it goes. This allows you to run this macro within a single workbook and still show you how it works. In a real-world example, the first part contains the name of the workbook where you get the data from and the second contains the name of the workbook where you want to place the data.

Read this tutorial to copy values from another workbook, even if it’s closed.

Notes

All examples in the attached workbook have been commented out. Simply remove the single quote from the line of code you want to test and then run the macro.

Download the attached file to get these examples in Excel.

Subscribe for Weekly Tutorials

BONUS: subscribe now to download our Top Tutorials Ebook!

Источник

0 / 0 / 0

Регистрация: 02.12.2018

Сообщений: 99

Excel

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

31.05.2019, 13:30. Показов 44379. Ответов 23

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

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

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

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

370 / 268 / 93

Регистрация: 18.11.2015

Сообщений: 990

31.05.2019, 13:31

А файл не приложили )

0 / 0 / 0

Регистрация: 02.12.2018

Сообщений: 99

31.05.2019, 13:32

[ТС]

ArtNord, сейчас минутку

вот файл

370 / 268 / 93

Регистрация: 18.11.2015

Сообщений: 990

31.05.2019, 13:43

Да, вижу, а что куда и по какому условию.
Все увидел внизу

0 / 0 / 0

Регистрация: 02.12.2018

Сообщений: 99

31.05.2019, 13:45

[ТС]

то что желтым выделено это условия, а синим это нужно перенести на лист 2

370 / 268 / 93

Регистрация: 18.11.2015

Сообщений: 990

31.05.2019, 14:07

Сообщение было отмечено Александр_80 как решение

Решение

Проверьте

370 / 268 / 93

Регистрация: 18.11.2015

Сообщений: 990

31.05.2019, 14:08

Александр_80, проверьте

0 / 0 / 0

Регистрация: 02.12.2018

Сообщений: 99

31.05.2019, 14:21

[ТС]

ArtNord, ДА ВСЕ РАБОТАЕТ ЭТО ПРОСТО МАГИЯ КАКАЯ ТО , ВОТ ТОЛЬКО Я ЗАБЫЛ УКАЗАТЬ НА КОЛОНКУ ДЮЙМЫ, МОЖНО ИХ ТОЖЕ КОПИРОВАТЬ? ПО ТЕМ ЖЕ УСЛОВИЯМ

370 / 268 / 93

Регистрация: 18.11.2015

Сообщений: 990

31.05.2019, 14:25

Добавил

Александр_80

0 / 0 / 0

Регистрация: 02.12.2018

Сообщений: 99

31.05.2019, 14:46

[ТС]

ArtNord, Вы просто супер!!!! Спасибо огромное вам!!!!! Еще одна просьба, вы не могли бы разъяснить по вашему макросу, что какая команда делает?

Visual Basic

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

ArtNord

370 / 268 / 93

Регистрация: 18.11.2015

Сообщений: 990

31.05.2019, 14:57

Спасибо за оценку!

Visual Basic

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

0 / 0 / 0

Регистрация: 02.12.2018

Сообщений: 99

31.05.2019, 15:01

[ТС]

ArtNord, вам спасибо за помощь!!! на самом деле в этой таблице более 50000 строк и она с каждым днем становится больше. Макрос будет работать на все эти строки?

ArtNord

370 / 268 / 93

Регистрация: 18.11.2015

Сообщений: 990

31.05.2019, 15:01

Visual Basic

Next CurRec
'Здесь можно добавить вывод сообщения об окончании работы макроса:
msgbox("Готово!")
End Sub

Да, вот эта строчка как раз и опреляет сколько сейчас записей:

Visual Basic

1	cAllRecs = Application.WorksheetFunction.CountA(Sheets("2").Range("B:B"))

0 / 0 / 0

Регистрация: 02.12.2018

Сообщений: 99

31.05.2019, 15:04

[ТС]

ArtNord, а если копировать нужно не на лист 2 а на другой лист который находится в другой книге, что нужно сделать?

ArtNord

370 / 268 / 93

Регистрация: 18.11.2015

Сообщений: 990

31.05.2019, 15:06

Если книга эта открыта то:

Visual Basic

1	Workbooks("Название книги.xls").Sheets("Название листа").Cells(cRecs, 27) = Sheets("1").Cells(CurRec, 11)

0 / 0 / 0

Регистрация: 02.12.2018

Сообщений: 99

31.05.2019, 15:12

[ТС]

простите меня я такой овощь в этом деле, я не пойму куда мне нужно эту строчку вставить?

ArtNord

370 / 268 / 93

Регистрация: 18.11.2015

Сообщений: 990

31.05.2019, 15:15

Где присваиваете значения:
В каждой строке вида:

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

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

Регистрация: 02.12.2018

Сообщений: 99

31.05.2019, 15:16

[ТС]

ArtNord, Вы просто супер!!!! Я если честно даже не ожидал, что мне так сразу тут помогут!!! Дай вам бог здоровья!!!

370 / 268 / 93

Регистрация: 18.11.2015

Сообщений: 990

31.05.2019, 15:17

Спасибо! Взаимно! Просто коротаю время до конца рабочего дня ))))

0 / 0 / 0

Регистрация: 02.12.2018

Сообщений: 99

31.05.2019, 15:23

[ТС]

ArtNord, нет не просто коротаете, вы людям помогаете!!!! Еще раз огромное спасибо ВАМ!!!!

Добавлено через 4 минуты
ArtNord, вы не подскажете, можно самому так научиться макросы писать, если да то где?

IT_Exp Эксперт 87844 / 49110 / 22898 Регистрация: 17.06.2006 Сообщений: 92,604	31.05.2019, 15:23
20

Источник

IGGI

Пользователь

Сообщений: 15
Регистрация: 01.01.1970

Добрый день!
У меня такая задача. На листе А есть таблица с данными. Мне нужно данные из заранее известных ячеек таблицы, по нажатию кнопки, скопировать на лист В, при этом, при нажатии на кнопку еще раз в этот же день, данные должны переноситься в тоже самое место (или больше не переноситься), а в другой день, через строку от нижней заполненной ячейки. Т.е. данные на листе В не должны затираться, а каждое последующее копирование должно располагаться на две строчки ниже.
Простыми словами, есть дневная статистика на листе А, ее нужно архивировать по нажатию кнопки, на лист В, с текущей датой. От одной и той же даты, данные на листе А, не могут быть разные, поэтому переносить их можно или один раз в день или просто записывать их в те же самые ячейки на листе В. В след. день, данные будут другие, их нужно расположить на листе В через строчку ниже, от предыдущих.
Буду очень рад Вашей помощи. Оговорюсь, в VBA знаний почти нет.
Спасибо.

Юрий М

Модератор

Сообщений: 60585
Регистрация: 14.09.2012

Контакты см. в профиле

14.06.2013 22:52:35

Цитата
IGGI пишет: в VBA знаний почти нет

В таком случае результат получите быстрее, если разместите свою тему в разделе «Работа». Но и там потребуется Ваш файл с исходными данным и с желаемым результатом. Или ждите здесь…

	как-то так — простенько без излишеств Изменено: kalbasiatka — 15.06.2013 00:44:31

IGGI Пользователь Сообщений: 15 Регистрация: 01.01.1970	Kalbasiatka, спасибо Вам огромное!!! Так быстро..) Это очень похоже на то что мне нужно. Буду пробовать адаптировать для своих данных)

IGGI

Пользователь

Сообщений: 15
Регистрация: 01.01.1970

kalbasiatka, Вы не могли бы подсказать, что нужно добавить, что бы на другую страницу переносились не только значения исходных ячеек, но и форматирование (фон ячейки, границы, шрифт и т.п)?
А так все получилось, очень рад Вашей помощи

kalbasiatka

Пользователь

Сообщений: 684
Регистрация: 22.12.2012

15.06.2013 21:03:19

может так?

Код

Sub uuu()
    With Sheets("Лист2")
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        If .Cells(lr, 1) = Date Then
            Range("A2, C2, E2").Copy .Cells(lr, 1)
        Else: Range("A2, C2, E2").Copy .Cells(lr + 2, 1)
        End If
    End With
End Sub

IGGI Пользователь Сообщений: 15 Регистрация: 01.01.1970	Да, это то, что нужно!) Спасибо Вам большое, все получилось!

IGGI

Пользователь

Сообщений: 15
Регистрация: 01.01.1970

Kolbasiatka, в моем случае все таки не получилось) В смысле у меня данные не в одной строке, а в разных. Как только в этой строке Else: Range(«A2, C2, E2» .Copy .Cells(lr + 2, 1) появляются данные из разных строк, выдает ошибку. Например вот так: Else: Range(«A2, C2,

» .Copy .Cells(lr + 2, 1) уже не получается. Нельзя ли написать макрос, в кот. я смогу подставлять данные из множества ячеек на листе из разных строк и столбцов?
Спасибо.

KuklP Пользователь Сообщений: 14868 Регистрация: 21.12.2012 E-mail и реквизиты в профиле.	Вот поэтому Вам и порекомендовали во 2-м посте перенести тему туда, где ей самое место. Я сам — дурнее всякого примера! …

Юрий М

Модератор

Сообщений: 60585
Регистрация: 14.09.2012

Контакты см. в профиле

#10

16.06.2013 15:06:03

Цитата
IGGI пишет: у меня данные не в одной строке, а в разных.

Вы об этом предупредили? Или свой файл-пример показали?

IGGI

Пользователь

Сообщений: 15
Регистрация: 01.01.1970

#11

16.06.2013 15:50:36

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

Цитата
KuklP пишет: Вот поэтому Вам и порекомендовали во 2-м посте перенести тему туда, где ей самое место.

Уважаемый, KukIP! Я так понимаю рекомендовали не Вы, Вы не модератор и по существу вопроса Вам сказать нечего. Во втором посте модератором было сказано «или ждите здесь». Так что не стоит засорять ветку, своими умными замечаниями, я разберусь без Вас.

Юрий М

Модератор

Сообщений: 60585
Регистрация: 14.09.2012

Контакты см. в профиле

#12

16.06.2013 15:57:14

Цитата
IGGI пишет: пример сделаю.

И это правильно!

KuklP

Пользователь

Сообщений: 14868
Регистрация: 21.12.2012

E-mail и реквизиты в профиле.

#13

16.06.2013 16:03:51

Цитата
IGGI пишет: по существу вопроса Вам сказать нечего.

Есть чего сказать. Но не для халявщиков. Тем более не для грубиянов-халявщиков. Персонально для Вас,IGGI, — форум не стол халявных заказов. Для заказов есть ветка «Работа»:

http://www.planetaexcel.ru/forum/?PAGE_NAME=list&FID=7

Цитата
IGGI пишет: У меня такая задача… в VBA знаний почти нет…

Вот там и уместно ставить задачи.

Я сам — дурнее всякого примера! …

IGGI

Пользователь

Сообщений: 15
Регистрация: 01.01.1970

#14

16.06.2013 16:30:24

Цитата
KuklP пишет: Есть чего сказать. Но не для халявщиков. Тем более не для грубиянов-халявщиков. Персонально для Вас, IGGI, — форум не стол халявных заказов. Для заказов есть ветка «Работа»:

)) Экий Вы, ранимый безнесмен.. Покажите мне грубость в моем посте и если она там есть, я извинюсь.
А вот лично Вас, я не прошу не о помощи, не о разъяснениях о том, что из себя представляет данный форум. Тут присутствуют люди, которые готовы помочь, не потрясая ящиком для благодарностей. Более пожалуйста не утруждайтесь, я и так потратил на Вас много времени.

IGGI Пользователь Сообщений: 15 Регистрация: 01.01.1970	Вот пример) Прикрепленные файлы Пример.xlsx (13.21 КБ)

IGGI

Пользователь

Сообщений: 15
Регистрация: 01.01.1970

#16

19.06.2013 17:21:33

Цитата
IGGI пишет: Вот пример)

Для потомков. Вопрос был решен с помощью такого макроса:

Код

Sub архив()
Application.ScreenUpdating = False
    With Sheets("архив")
        lr = .Cells(Rows.Count, 2).End(xlUp).Row
        If .Cells(lr, 2) = Date Then
            Range("B5").Copy .Cells(lr - 1, 2)
            Range("C5").Copy
            .Cells(lr, 2).PasteSpecial Paste:=xlPasteValues
            .Cells(lr, 2).PasteSpecial Paste:=xlPasteFormats
            Range("J13:N13").Copy .Cells(lr - 1, 3)
            Range("C13:C17").Copy
            .Cells(lr, 3).PasteSpecial Transpose:=True
        Else
            Range("B5").Copy .Cells(lr + 2, 2)
            Range("C5").Copy
            .Cells(lr + 3, 2).PasteSpecial Paste:=xlPasteValues 'специальная вставка значения
            .Cells(lr + 3, 2).PasteSpecial Paste:=xlPasteFormats 'специальная вставка форматы
            Range("J13:N13").Copy .Cells(lr + 2, 3)
            Range("C13:C17").Copy
            .Cells(lr + 3, 3).PasteSpecial Transpose:=True
        End If
    End With
Application.ScreenUpdating = True
End Sub

Спасибо!

faridvg Пользователь Сообщений: 33 Регистрация: 10.12.2014	Здравствуйте. А можно изменить этот макрос, чтоб он записывал данные на лист Б подряд и убрать привязку к дате? Спасибо. Изменено: faridvg — 11.07.2017 13:15:49

vikttur Пользователь Сообщений: 47199 Регистрация: 15.09.2012	Лучше создать новую тему с названием, отражающим суть задачи.

ANSWERIVER

Пользователь

Сообщений: 76
Регистрация: 05.02.2015

#19

12.12.2018 15:18:55

Всем привет,

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

Код

Private Sub CommandButton3_Click()

    Range("F2").Copy
    Range("K2").Select
    ActiveSheet.Paste
    Range("F3").Copy
    Range("K3").Select
    ActiveSheet.Paste
    Range("F4").Copy
    Range("K4").Select
    ActiveSheet.Paste
    Range("F5").Copy
    Range("K5").Select
    ActiveSheet.Paste

Изменено: ANSWERIVER — 12.12.2018 15:19:37

Источник

Решение задачи по копированию данных с одного листа на другой без использования и с использованием массивов. Вызов из кода VBA Excel других процедур.

Условие задачи по копированию данных

На одном листе расположен список повторяющихся городов с информацией о предприятиях общепита:

Исходная таблица задания №1

Необходимо данные по каждому городу перенести в одну строку на другом листе (таблица обрезана справа):

Часть результирующего списка задания №1

Решение копированием с листа на лист

Это решение значительно проще, чем с использованием массивов, но более медленное. При больших объемах информации обработка может длиться достаточно долго. Решение достигается путем присваивания значений ячеек из таблицы первого листа ячейкам второго листа.

Sub Resheniye1()

Dim n1 As Long, n2 As Long, n3 As Long, n4 As Long, _

i1 As Long, gorod As Variant

n1 = Sheets(«Лист1»).Cells(1, 1).CurrentRegion.Rows.Count

For i1 = 1 To n1

With Sheets(«Лист1»)

If gorod <> .Cells(i1, 1) Then

gorod = .Cells(i1, 1)

n2 = 1

n3 = n3 + 1

n4 = 1

Else

n2 = 2

End If

Do While .Cells(i1, n2) <> «»

Sheets(«Лист2»).Cells(n3, n4) = .Cells(i1, n2)

n4 = n4 + 1

n2 = n2 + 1

Loop

End With

End Sub

Переменные:

n1 – количество строк в исходной таблице;
n2 – номер столбца текущей ячейки исходной таблицы, к которой обращается цикл;
n3 – номер строки текущей ячейки на втором листе;
n4 – номер столбца текущей ячейки на втором листе;
i1 – счетчик цикла For… Next;
gorod – переменная с наименованием города, предназначенная для контроля за сменой текущего города, который обрабатывается циклом.

Решение с использованием массивов

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

‘Объявление глобальных переменных

‘в разделе Declarations

Dim massiv1 As Variant, n2 As Long, _

n3 As Long, i1 As Long, txt1 As Variant

‘Исполняемая процедура для решения

‘задания вторым способом

Sub Resheniye2()

Dim n1 As Long, gorod As Variant

With Sheets(«Лист1»).Cells(1, 1)

massiv1 = .CurrentRegion

n1 = .CurrentRegion.Rows.Count

n2 = .CurrentRegion.Columns.Count

End With

n3 = 0

txt1 = «»

For i1 = 1 To n1

If gorod <> massiv1(i1, 1) Then

If txt1 <> «» Then

Call Vstavka

End If

gorod = massiv1(i1, 1)

txt1 = massiv1(i1, 1)

Call Kopirovanie

Else

Call Kopirovanie

End If

If i1 = n1 Then

Call Vstavka

End If

End Sub

‘Копирование данных из массива в

‘строковую переменную через разделитель

Sub Kopirovanie()

Dim i2 As Long

For i2 = 2 To n2

If massiv1(i1, i2) <> Empty Then

txt1 = txt1 & «|» & massiv1(i1, i2)

End If

End Sub

‘Обработка данных из строковой

‘переменной в дополнительных массивах и

‘вставка очередной строки на второй лист

Sub Vstavka()

Dim n4 As Long, massiv2 As Variant, _

massiv3 As Variant, i3 As Long

n3 = n3 + 1

massiv2 = Split(txt1, «|»)

n4 = UBound(massiv2)

ReDim massiv3(0 To 0, 0 To n4)

For i3 = 0 To n4

massiv3(0, i3) = massiv2(i3)

Sheets(«Лист2»).Range(Cells(n3, 1), _

Cells(n3, n4 + 1)).Value = massiv3

End Sub

Подпрограммы Kopirovanie и Vstavka используются в цикле For... Next процедуры Resheniye2 по два раза, поэтому их коды вынесены за пределы процедуры Resheniye2 и вызываются по мере необходимости.

Переменные:

massiv1 – его элементам присваиваются значения ячеек исходной таблицы;
massiv2 – одномерный массив, заполняемый данными из переменной txt1;
massiv3 – двумерный массив, заполняемый данными из одномерного массива massiv2 и используемый для вставки очередной строки на второй лист;
txt1 – сюда копируются через разделитель значения элементов массива massiv1, предназначенные для заполнения очередной строки на втором листе;
n1 – количество строк в исходной таблице;
n2 – количество столбцов в исходной таблице;
n3 – номер текущей строки на втором листе;
n4 – количество столбцов текущей строки на втором листе (соответствует количеству элементов массива massiv2);
i1, i2, i3 – счетчики цикла For… Next;
gorod – переменная с наименованием города, предназначенная для контроля за сменой текущего города, который обрабатывается циклом.

Переменные, использующиеся более чем в одной процедуре, объявлены как глобальные в разделе Declarations программного модуля.

Источник

Макрос копирования данных с разных листов на один лист

Nat

Дата: Четверг, 29.08.2013, 22:31 |
Сообщение № 1

Группа: Пользователи

Ранг: Участник

Сообщений: 50

Репутация:
0
±

Замечаний:
0% ±

Excel 2010

Добрый день!

Мне потребовалось написать макрос, но с ними я совсем не дружу, поэтому надеюсь на Вашу помощь. Нужно скопировать данные с разных листов на итоговый лист одной и той же книги Excel. Количество столбцов всегда одинаковое, а вот количество строк и листов — разное. При этом желательно, чтобы первую страницу он копировал с заголовком, а остальные — без. Файл прилагаю.

P.S. Пункт 5q в правилах форума я не нашла, поэтому заранее извиняюсь, если опять сделала что-то не так.

К сообщению приложен файл:

3838011.xls
(62.5 Kb)

Ответить

Hugo

Дата: Пятница, 30.08.2013, 00:25 |
Сообщение № 2

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3140

Репутация:
670
±

Замечаний:
0% ±

2010, теперь уже с PQ

Как это не нашли?
Вот он, под спойлером:
q — задавать новые вопросы в уже созданных чужих или своих темах

excel@nxt.ru
webmoney: R418926282008 Z422237915069

Ответить

Hugo

Дата: Пятница, 30.08.2013, 01:17 |
Сообщение № 3

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3140

Репутация:
670
±

Замечаний:
0% ±

2010, теперь уже с PQ

[vba]

Код

Option Explicit

Sub CopyData()
Dim sh As Worksheet, r As Range, i&
Application.ScreenUpdating = False

       Set sh = Worksheets.Add(before:=Worksheets(1))
       Set r = Worksheets(2).Columns(1).Find(1, , xlValues, xlWhole)
       If Not r Is Nothing Then
           r.Offset(-2).EntireRow.Resize(3).Copy sh.Cells(1)
           For i = 2 To Worksheets.Count
               With Worksheets(i)
                   Set r = .Columns(1).Find(1, , xlValues, xlWhole)
                   If Not r Is Nothing Then
                       .Range(r.Offset(1), .Range(«AJ» & .Rows.Count).End(xlUp)).Copy _
                     Worksheets(1).Range(«B» & .Rows.Count).End(xlUp)(2).Offset(, -1)
                   End If
               End With
           Next
       End If
       Application.ScreenUpdating = True
End Sub

[/vba]
Сперва искал по «Дата отправки КС» — но что-то на последнем листе не искалось (на том, который как пример собранного). Так и не понял, почему — переделал на поиск единицы

excel@nxt.ru
webmoney: R418926282008 Z422237915069

Ответить

SergeyKorotun

Дата: Пятница, 30.08.2013, 02:17 |
Сообщение № 4

Группа: Проверенные

Ранг: Обитатель

Сообщений: 301

Репутация:
15
±

Замечаний:
0% ±

Excel 2007

Опередили
[vba]

Код

Sub Start()
     Call CreateSheet
     Call Copy
End Sub
Private Sub CreateSheet()
    On Error Resume Next
    Set wsSheet = Sheets(«Итог»)
    If Err.Number = 0 Then
       Application.DisplayAlerts = False
       Sheets(«Итог»).Delete
       Application.DisplayAlerts = True
    End If
    Sheets.Add After:=Sheets(Sheets.Count)
    Sheets(Sheets.Count).Name = «Итог»
End Sub
Private Sub Copy()
  Dim sRng As Range
  Dim dRng As Range
     Application.ScreenUpdating = False
     ThisWorkbook.Sheets(1).Activate
     Set sRng = Range(«A9:AJ11»)
     ThisWorkbook.Sheets(Sheets.Count).Activate
     Set dRng = Range(«A1»)
     sRng.Copy dRng
     For i = 1 To ThisWorkbook.Sheets.Count — 1
        ThisWorkbook.Sheets(i).Activate
        Set sRng = Range(Cells(12, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
        ThisWorkbook.Sheets(Sheets.Count).Activate
        Set dRng = Cells(ActiveSheet.UsedRange.Rows.Count + 1, 1)
        sRng.Copy dRng
     Next i
     Application.ScreenUpdating = True
End Sub

[/vba]

К сообщению приложен файл:

qwerty_.xlsm
(32.0 Kb)

Ответить

Nat

Дата: Пятница, 30.08.2013, 15:09 |
Сообщение № 5

Группа: Пользователи

Ранг: Участник

Сообщений: 50

Репутация:
0
±

Замечаний:
0% ±

Excel 2010

Благодарю за помощь! Первый вариант рабочий. Во втором макрос копировал в исходную книгу (удалила «ThisWorkbook» в тексте — стал копировать в новый документ, хотя не уверена что именно это н.б. сделать) и только первые два листа (как это исправить — не знаю, да это уже и не так важно)…Полезная это вещь — макросы! Надо будет освоить хотя бы азы. Еще раз спасибо за помощь!

Ответить

SergeyKorotun

Дата: Пятница, 30.08.2013, 15:27 |
Сообщение № 6

Группа: Проверенные

Ранг: Обитатель

Сообщений: 301

Репутация:
15
±

Замечаний:
0% ±

Excel 2007

Nat, ThisWorkbook — это книга с которой вы запускаете макрос. По всей видимости вы вставили макрос не в ту книгу.
[vba]

Код

For i = 1 To ThisWorkbook.Sheets.Count — 1

[/vba] с первого листа по предпоследний.
Копирует только с двух наверно по той самой причине: не в ту книгу вставили макрос.
Скачайте qwerty_.xlsm, добавьте туда листов и запустите макрос и вы увидите что макрос обработает все листы.
В варианте Hugo в итоговом листе при повторных запусках строки будут дублироваться.

Ответить

Nat

Дата: Пятница, 30.08.2013, 15:52 |
Сообщение № 7

Группа: Пользователи

Ранг: Участник

Сообщений: 50

Репутация:
0
±

Замечаний:
0% ±

Excel 2010

Да, с дублированием в варианте Hugo я уже столкнулась.
Последовала вашему совету и поновой запустила макрос — действительно все ок. Спасибо!

Ответить

Hugo

Дата: Пятница, 30.08.2013, 17:30 |
Сообщение № 8

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3140

Репутация:
670
±

Замечаний:
0% ±

2010, теперь уже с PQ

Не запускайте повторно — не будет дублироваться
Если есть такая мания — нужно всего лишь добавить в код удаление первого листа. Если он тот, который лишний. Ну в общем этот вопрос не вопрос.
Зато у меня таблицы могут скакать по листу, и не скопируется лишнее, как в случае
[vba]

Код

Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))

[/vba]Тут может и недокопироваться, и лишнее скопироваться — зависит от файла. Но если файлы всегда будут именно такие и никто туда руки не сунет — тогда ладно

excel@nxt.ru
webmoney: R418926282008 Z422237915069

Ответить

exelskatyazhelyi

Дата: Воскресенье, 19.02.2017, 08:53 |
Сообщение № 9

Группа: Пользователи

Ранг: Новичок

Сообщений: 15

Репутация:
0
±

Замечаний:
0% ±

Excel 2010

Hugo, привет, всем Гуру экселя. Не могу разобраться с макросом, совсем вот уже 3 день. Нужно собрать данные со всех листов в один, листов больше 100 штук, постоянно дополняется. Кол-во столбцов одинаковое, строк-разное. может кто сможет помочь?

Ответить

Pelena

Дата: Воскресенье, 19.02.2017, 09:13 |
Сообщение № 10

Группа: Админы

Ранг: Местный житель

Сообщений: 18797

Репутация:
4284
±

Замечаний:
±

Excel 2016 & Mac Excel

exelskatyazhelyi, прочитайте Правила форума и создайте свою тему.
Эта тема закрыта

«Черт возьми, Холмс! Но как??!!»
Ю-money 41001765434816

Ответить

Источник