Как в excel перенести данные с одного листа на другой vba - Word и Excel

Решение задачи по копированию данных с одного листа на другой без использования и с использованием массивов. Вызов из кода 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 программного модуля.

Источник

sbirliko

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

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

sbi

Уважаемые форумчане!
Помогите пожалуйста с написанием макроса, который по условию переносит данные с одного листа на другой.
Более детально указано в приложенном файле.

Заранее спасибо!
С уважением,
sbirliko

Прикрепленные файлы

Book1.xlsx (11.35 КБ)

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

МВТ

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

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

07.04.2015 12:56:06

Несмотря на то, что я полностью согласен с KuklP, вот код:

Код

Sub tt()
Dim L As Long: L = 3
Application.ScreenUpdating = False
With Sheets("History_")
.Unprotect
.Range("B3:I" & Cells(Rows.Count, 2).End(xlUp)).Clear
End With
Sheets("Action-Log").Activate
For I = 3 To Cells(Rows.Count, 2).End(xlUp).Row
If Cells(I, 11) = "Выполнен" Then
Range("C" & I & ":H" & I).Copy Destination:=Sheets("History_").Range("C" & L)
Range("K" & I).Copy Destination:=Sheets("History_").Range("I" & L)
With Sheets("History_").Cells(L, 2)
    .Value = L - 2
    .Borders.LineStyle = 1
End With
L = L + 1
End If
Next I
Sheets("History_").Protect
Application.ScreenUpdating = True
End Sub

sbirliko

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

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

sbi

07.04.2015 13:00:03

KuklP

добрый день.

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

Код

Sub Запрос()'
    Sheets("Лист2";).Select
    Range("B2";).Select
    ActiveCell.FormulaR1C1 = _
        "=IF(ISNA(VLOOKUP(RC[-1],Лист1!R1C3:R1000C6,4,0)),"""",VLOOKUP(RC[-1],Лист1!R1C3:R1000C6,4,0))"
    Range("B2";).Select
    Selection.Copy
    Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
    ActiveSheet.Paste
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("A1";).Select
    Application.CutCopyMode = False
End Sub

и Sub Perenos()Dim iLastRow As Long
    iLastRow = Range("A8";).End(xlDown).Row
        Range("A8:F" & iLastRow).Copy _
        Sheets("База";).Range("A" & Sheets("База";).Cells(Rows.Count, 1).End(xlUp).Row + 1)
End Sub

а сделать это через макроредактор сложно, т.к. я не знаю как создать привязку к условию(то что указано в примере)

ну уж простите, если это тема уже приелась…

МВТ Пользователь Сообщений: 1198 Регистрация: 01.02.2015	sbirliko, не расстраивайтесь и оформите код макроса как положено (кнопка <…>). Макрос я написал по Вашим таблицам, попробуйте

sbirliko Пользователь Сообщений: 98 Регистрация: 22.12.2013 sbi	МВТ , Спасибо большое! Но, кажется ваш код написан вовсе не макроредактором….))) И еще один момент, возможно ли удаление строк из листа Action-Log, которые были перенесены на лист History_?

МВТ

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

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

sbirliko, я и не говорил, что рекордером . Да строки можно удалять, вставлять или менять: после окончания работы макроса таблицы никак друг с другом не связаны. Таблица-результат не имеет ссылок на Таблицу-источник, макрос просто снимает защиту, копирует отобранную информацию на другой лист и снова ставит защиту.

KuklP

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

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

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

07.04.2015 13:52:05

Вариант:

Код

Sub www()
    Sheets("History_").Unprotect "123"
    Sheets("History_").UsedRange.ClearContents
    With Sheets("Action-Log").Range("B2").CurrentRegion
        .AutoFilter 10, "Выполнен"
        .Copy Sheets("History_").Range("B2")
        .Parent.AutoFilterMode = 0
    End With
    Sheets("History_").Protect "123"
End Sub

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

KuklP

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

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

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

07.04.2015 14:08:12

Забыл. Так еще и удалит строки с исходной. И это — макрорекордером. С доработкой.

Код

Sub www()
    Sheets("History_").Unprotect "123"
    Sheets("History_").UsedRange.ClearContents
    With Sheets("Action-Log").Range("B2").CurrentRegion
        .AutoFilter 10, "Выполнен"
        .Copy Sheets("History_").Range("B2")
        .Offset(1).SpecialCells(12).EntireRow.Delete
        .Parent.AutoFilterMode = 0
    End With
    Sheets("History_").Protect "123"
End Sub

Прикрепленные файлы

Book1.xlsm (17.59 КБ)

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

МВТ Пользователь Сообщений: 1198 Регистрация: 01.02.2015	KuklP, идея с автофильтром хороша (не сообразил, честно), но там надо не все колонки переносить и нумерацию обновлять

sbirliko

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

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

sbi

c нумерацией нет проблем, можно не обновлять… но возник другой вопросик, вернее я упустил(результат нехватки времени , простите, приходится писать только когда есть свободная минутка)

возможно ли доработка макроса для добавления перенесенных данных на последнюю свободную строку в листе History_?
Т.е. необходимо видить общий объем перенесенных данных(строк) за все время…

ps-скачал книгу Мэтью Харрис по VBA, буду изучать дома, по выходным… (хотя нет инета и компа дома, хоть буду теорию знать)

МВТ

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

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

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

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

KuklP

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

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

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

#14

07.04.2015 15:04:04

Так, вроде все учел:

Код

Sub www()
    Dim lr
    With Sheets("History_")
        lr = .Cells(65536, 2).End(xlUp).Row + 1
        .Unprotect "123"
        '        .UsedRange.Clear
    End With
    With Sheets("Action-Log").Range("B2").CurrentRegion
        .Columns("H:I").Hidden = -1
        .AutoFilter 10, "Выполнен"
        If lr = 2 Then
            .Copy Sheets("History_").Range("B2")
        Else
            .Offset(1).Copy Sheets("History_").Range("B" & lr)
        End If
        .Columns("H:I").Hidden = 0
        .Offset(1).SpecialCells(12).EntireRow.Delete
        .Parent.AutoFilterMode = 0
    End With
    Sheets("History_").Protect "123"
End Sub

Прикрепленные файлы

Book1.xlsm (19.65 КБ)

Изменено: KuklP — 07.04.2015 15:09:45

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

sbirliko Пользователь Сообщений: 98 Регистрация: 22.12.2013 sbi	KuklP и МВТ большое спасибо за оказанную помощь!

Strizh Пользователь Сообщений: 76 Регистрация: 04.07.2018	Отличный макрос, огромнейшее спасибо!

Strizh Пользователь Сообщений: 76 Регистрация: 04.07.2018	#17 26.07.2019 16:38:04 KuklP, добрый день! Вы не смогли бы изменить макрос таким образом, чтобы он смог переносить данные на другой лист ПОСТРОЧНО. В моем документе я выбираю данные на листе 1 и переношу их на лист 2 с учетом даты. По идее, макрос должен найти пустую строку и вставить туда скопированное значение.

Источник

Есть книга, в которой 10 листов. Нужно скопировать содержимое 8-го листа в 3-й лист.

Я пытался сделать это следующим способом:

Set CurrentWorkbook = ThisWorkbook
Set sheetTemp = CurrentWorkbook.Worksheets(8)

With Application: .ScreenUpdating = False: .DisplayAlerts = False: End With
With CurrentWorkbook
     sheetTemp.Copy CurrentWorkbook.Worksheets(3)
End With
With Application: .ScreenUpdating = True: .DisplayAlerts = True: End With

Все работает, но вместо записи в 3-й лист оно создает перед третьим листом новый лист. Как сделать так, чтобы при копировании не создавался новый лист и записывалось в существующий лист?

задан 21 сен 2018 в 10:35

Полное копирование столбцов (ширина, форматирование, значения, примечания…):

Sub CopyRange()
    Worksheets("Лист1").Columns("C:E").Copy
    Worksheets("Лист2").Columns("C:E").PasteSpecial
End Sub

или

Sub CopyRange()
    Worksheets("Лист1").Columns("C:E").Copy Worksheets("Лист2").Columns("C:E")
End Sub

Для копирования только нужного:

  Worksheets("Лист1").Range("C3:E50").Copy

  With Worksheets("Лист2").Range("C3")
      .PasteSpecial xlPasteColumnWidths ' ширина столбца'
      .PasteSpecial xlPasteValues' значения'
      .PasteSpecial xlPasteFormats' форматы'
      .PasteSpecial xlPasteFormulasAndNumberFormats ' формулы'
      ' .....'
  End With

После копирования очистить буфер:

Application.CutCopyMode = False

ответ дан 21 сен 2018 в 11:38

Источник

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

Sub Название_Макроса()

'Выделить диапазон который необходимо скопировать
Range("A1:F52").Select
'Скопировать то, что выделено
Selection.Copy
ChDir "путь к папке где лежит файл в который необходимо скопировать"
Workbooks.Open Filename:= "Название файла, который находится в папке, путь к которой указан выше"
'Выделить начальную ячейку в которую необходимо вставить скопированные данные
Range("A6").Select
'Вставить данные
ActiveSheet.Paste
'сохранить текущую книгу
ActiveWorkbook.Save
'Закрыть книгу
ActiveWorkbook.Close
End Sub

Вариант 2: В открывшейся книге запускаем макрос, чтобы он открыл нужную нам книгу, скопировал от туда нужные нам данные и вставил в нашу открытую книгу, закрыв файл из которого эти данные были скопированы

Sub Название_Макроса2()
'Открываем файл с которого нужно скопировать данные
Workbooks.Open Filename:="C:Данные.xlsx"

'Скопировать нужный диапазон в открывшейся книге на листе 1
Workbooks("Данные.xlsx").Worksheets("Лист1").Range("A16:E16").Copy
'Активируем нужную нам книгу
Workbooks("Книга1.xlsm").Activate

'Выделяем и вставляем скопированные данные в ячейку А1
ActiveWorkbook.Worksheets("Лист1").Range("A1").Select
ActiveSheet.Paste

'Закрываем книгу откуда мы скопировали данные
Workbooks("Данные.xlsx").Close

End Sub

Еще пример — Скопировать диапазоны данных из активной открытой книги Excel нескольких листов (в нашем примере 3-х листов) в другую книгу, которая хранится в определенном месте. Данные будут вставлены как значения, плюс будут перенесены форматы ячеек.

Sub Копируем_листы_в_другую_книгу()
Dim bookconst As Workbook
Dim abook As Workbook
Set abook = ActiveWorkbook 'присваиваем перменную активной книге
Set bookconst = Workbooks.Open("C:UsersUserDesktop1.xlsx") 'присваиваем перменную книге куда необходимо копировать данные

'переходим в активную книгу откуда необходимо скопировать данные
abook.Worksheets("Лист1").Activate
Range("A1:I23").Copy 'копируем определенный диапазон листа, укажите свой диапазон
bookconst.Worksheets("Лист1").Activate 'активируем лист куда необходимо вставить данные
Range("A1:I23").Select 'встаем на ячейку А1
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'вставляем только форматы ячеек
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'второй лист
abook.Worksheets("Лист2").Activate
Range("A1:I23").Copy
bookconst.Worksheets("Лист2").Activate
Range("A1:I23").Select 'выделяем диапазон
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'вставляем только форматы ячеек
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'третий лист
abook.Worksheets("Лист3").Activate
Range("A1:I23").Copy
bookconst.Worksheets("Лист3").Activate
Range("A1:I23").Select 'выделяем диапазон
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'вставляем только форматы ячеек
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'сохранить текущую книгу
bookconst.Save
'Закрыть книгу
bookconst.Close
abook.Activate

End Sub

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

Спасибо за внимание.

Источник

0 / 0 / 0

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

Сообщений: 99

Excel

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

31.05.2019, 13:30. Показов 44371. Ответов 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

Источник

У меня есть книга Excel с 4 листами.

Мастер лист
test_1
test_2
test_3

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

Я вставил свой существующий код ниже:

Sub sbCopyRangeToAnotherSheet()
    Sheets("Master").Range("B10:M1628").Copy
    Sheets("test_1").Activate
    Range("B9").Select
    ActiveSheet.Paste
    Application.CutCopyMode = Flase
End Sub


Sub sbCopyRangeToCRP2()
    Sheets("Master").Range("B10:M1628").Copy
    Sheets("test_2").Activate
    Range("B9").Select
    ActiveSheet.Paste
    Application.CutCopyMode = Flase
End Sub


Sub sbCopyRangeToCRP3()
    Sheets("Master").Range("B10:M1628").Copy
    Sheets("test_3").Activate
    Range("B9").Select
    ActiveSheet.Paste
    Application.CutCopyMode = Flase
End Sub

В приведенном выше коде я упомянул жестко закодированное значение диапазона мастер-листа, которое начинается с B10 и заканчивается на M1628.

В дальнейшем количество строк увеличивается **(диапазон B10 останется)** и я не хочу жестко кодировать диапазон. Как я могу сделать это?

2017-03-14 08:10

4

ответа

Решение

Я предлагаю объединить эти 3 подпрограммы в одну, которую вы можете использовать повторно, указав рабочий лист в качестве параметра:

Sub sbCopyRangeToAnotherSheet(ToSheet As Worksheet)
    Dim LastUsedRow As Long

    With Sheets("Master")
        LastUsedRow = .UsedRange.Row + .UsedRange.Rows.Count - 1
        .Range("B10:M" & LastUsedRow).Copy ToSheet.Range("B9")
    End With

    Application.CutCopyMode = False
End Sub

Затем вы можете запустить этот саб для любого имени листа, как

Sub test_1()
    sbCopyRangeToAnotherSheet Sheets("test_1")
    'and for the second sheet
    sbCopyRangeToAnotherSheet Sheets("test_2")
End Sub

2017-03-14 08:33

Я бы предложил либо использовать UsedRange свойство объекта Worksheet,

или определить именованные диапазоны на листе, которые автоматически расширяются по мере роста данных на листе, например: =OFFSET($A$1,0,0,COUNTA($A:$A),1)

2017-03-14 08:15

Вы можете использовать этот макрос

Sub CopyAll()
    Dim src As Range, dest
    With Worksheets("Master") ' set the source range
        Set src = .Range("B10:M" & .Cells(.Rows.Count, "B").End(xlUp).Row)
    End With
    For Each dest In Array("test_1", "test_2", "test_3") ' loop on destination sheets
        src.Copy Worksheets(dest).Range("B9")
    Next
End Sub

2017-03-14 08:41

Я думаю, что самый простой способ скопировать данные — это использовать массив, который заполнен динамически.

Создать точный массив
Заполните данные из мастер-листа
Вставьте данные.

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

Sub sbCopyRangeToAnotherSheet()
Sheets("Master").Select
Dim RowNum as integer 
For i = 0 To 250000 'Count all rows
    If IsEmpty(Cells(i + 10, 2)) = False Then
        RowNum = RowNum + 1 'Count all rows which have data in it's second column
    Else
        Exit For
    End If
Next
ReDim myData(RowNum - 1, 12) As String 'create array
For i = 0 To RowNum - 1 'fill array, with data
    For j = 0 to 12
    myData(i, j) = Cells(i + 10, j+2) '+10 because you said B**10**
                                      '+2 because you said **B**10
    Next
Next

Sheets("test_1").Activate
For i = 0 To RowNum - 1 'fill array, with data
    For j = 0 to 12
    Cells(i + 10, j+2) = myData(i, j) 'Fill cells with data
    Next
Next
End Sub

2017-03-14 08:38

Источник

Перенос заполненных ячеек на другой лист этой же книги

Controler

Дата: Понедельник, 14.03.2016, 07:52 |
Сообщение № 1

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

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

Сообщений: 14

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

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

Excel 2007

Всем добрый день!

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

[vba]

Код

Sub Перенос()
Sheets(«Отчет за сутки).Range(«A:j»).SpecialCells(2).Copy Sheets(«Отчет за 2016 г.»).Range(«A» & Rows.Count).End(xlUp)
ThisWorkbook.Sheets(«Отчет за сутки»).Copy
Sheets(«Отчет за сутки»).Range(«a2:j10»).ClearContents
MsgBox («Данные в отчет за 2016 г. внесены!»)
End Sub

[/vba]

У меня почему копируются ячейки с названием столбцов, а мне нужно чтобы копировались только данные
[moder]Оформляйте коды тегами (кнопка #). На первый раз исправила[/moder]

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

2192281.xls
(76.0 Kb)

Ответить

KuklP

Дата: Понедельник, 14.03.2016, 08:30 |
Сообщение № 2

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

Ранг: Старожил

Сообщений: 2369

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

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

2003-2010

[vba]

Код

Sub Перенос()
    With ThisWorkbook.Sheets(«Отчет за сутки»)
        .Range(«A2:j» & .Cells(.Rows.Count, 1).End(xlUp).Row).SpecialCells(2).Copy Sheets(«Отчет за 2016 г.»).Range(«A» & Rows.Count).End(xlUp)
        .Copy
        .Range(«A2:j» & .Cells(.Rows.Count, 1).End(xlUp).Row).ClearContents
        MsgBox («Данные в отчет за 2016 г. внесены!»)
    End With
End Sub

[/vba]

Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728

Ответить

Controler

Дата: Понедельник, 14.03.2016, 08:56 |
Сообщение № 3

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

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

Сообщений: 14

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

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

Excel 2007

цитата удалена

С этим макросом данные копируются на другой лист, но при этом стирается 1 строка названием столбцов, и следующая вставка ячеек происходит со второй строки, надо чтобы данные вносились после последней заполненной строки, при этом оставался заголов 1 строки с названиями столбцов
[moder]
Не надо цитировать посты целиком, это нарушение Правил форума.[/moder]

Ответить

KuklP

Дата: Понедельник, 14.03.2016, 09:45 |
Сообщение № 4

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

Ранг: Старожил

Сообщений: 2369

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

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

2003-2010

В Вашем файе-примере НЕТ данных. Вот заполните таблицы данными, попробуйте, а потом уж сюда, если что не так. И с файлом с данными. Мне не настолько нечего делать, чтоб рисовать за вас примеры.

Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728

Ответить

Controler

Дата: Понедельник, 14.03.2016, 10:47 |
Сообщение № 5

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

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

Сообщений: 14

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

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

Excel 2007

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

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

0258731.xls
(81.5 Kb)

Ответить

KuklP

Дата: Понедельник, 14.03.2016, 10:58 |
Сообщение № 6

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

Ранг: Старожил

Сообщений: 2369

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

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

2003-2010

И что не так? Попробовал — все внеслось, записалось, скопировалось и очистилось. Заголовки нетронуты. В Вашем макросе кстати будет затираться последняя строка в Отчет за 2016 г. Если это не планировалось специально, то лучше:
[vba]

Код

.Range(«A2:j» & .Cells(.Rows.Count, 1).End(xlUp).Row).SpecialCells(2).Copy Sheets(«Отчет за 2016 г.»).Range(«A» & Rows.Count).End(xlUp)(2)

[/vba]

Ну с НДС и мы чего-то стoим! kuklp60@gmail.com
WM Z206653985942, R334086032478, U238399322728

Ответить

Источник

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

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

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

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

Решение

4 ответа

4

ответа