Перенести данных с листа на лист vba excel

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

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

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

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

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

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

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

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

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

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

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

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

  Next

End Sub

Переменные:

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

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

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

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

24

25

26

27

28

29

30

31

32

33

34

35

36

37

38

39

40

41

42

43

44

45

46

47

48

49

50

51

52

53

54

55

56

57

58

59

60

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

‘в разделе 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

  Next

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

  Next

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)

  Next

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

#3

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

#4

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 и реквизиты в профиле.

#8

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 и реквизиты в профиле.

#9

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 нумерацией нет проблем, можно не обновлять… но возник другой вопросик, вернее я упустил(результат нехватки времени :sceptic:, простите, приходится писать только когда есть свободная минутка)

возможно ли доработка макроса для добавления перенесенных данных на последнюю свободную строку в листе 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 КБ)

Изменено: KuklP07.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-й лист оно создает перед третьим листом новый лист. Как сделать так, чтобы при копировании не создавался новый лист и записывалось в существующий лист?

vikttur_Stop_RU_war_in_UA's user avatar

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

Leksor's user avatar

2

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

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

vikttur_Stop_RU_war_in_UA's user avatar

Задача состоит в том, чтобы скопировать определенный диапазон текущего листа, открыть другую книгу, и вставить эти скопированные данные в определенную ячейку, сохранить этот файл и закрыть. Ниже приведен код 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

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

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

На одном листе таблица из этой таблицы нужно перенести данные для расчета в квитанции, другой лист. Например в ячейку на листе 2 фиО если на первой странице Новиков Илья Васильевич она должна отобразиться в ячейке A4 «=’1′!C5» потом сумма переработки, она относится к «=’1′!AS5», потом вычеты они относятся к «=’1′!AW5» и так далее, как вы выше писали, так и надо прописать. Все эти данные относятся к строке пять, следующий человек к строке 6 и все те же данные. Вот как макрос прописать я незнаю, пробывал у меня не получилось.

Добавлено через 11 минут
Алгоритм
На листе 2 нажимаю на ячейку A4, в этой ячейке ставлю формулу «=’1′!AW5», далее под графой «Сумма переработки» на листе 2 ставлю «=’1′!AS5», далее аналогично под графой «Вычеты»
ставлю «=’1′!AW5», далее под графой «Командировочны» ставлю «=’1′!AT5», далее на листе 2 под графой «доплата за а/м
ставлю «=’1′!BC5», далее так же на листе 2 под графой Оклад ставлю «=’1′!AQ5», далее на листе 2 под графой «Оклад» ставлю «=’1′!AQ5», далее под графой авнс на 2 листе ставлю
«=’1′!BF5», далее под графой доп.выплаты ставлю «=’1′!BC5».

Like this post? Please share to your friends:
  • Перенести данные с одного листа на другой excel определенных ячеек как
  • Перенести все колонки в одну excel
  • Перенести word документ в iphone
  • Перенеси с помощью впр excel
  • Перемножение ячеек в excel формула