Макрос копирование данных с листа на лист в excel по условию

0 / 0 / 0

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

Сообщений: 99

1

Excel

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

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


Студворк — интернет-сервис помощи студентам

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

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

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

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



0



370 / 268 / 93

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

Сообщений: 990

31.05.2019, 13:31

2

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



0



0 / 0 / 0

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

Сообщений: 99

31.05.2019, 13:32

 [ТС]

3

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

вот файл



0



370 / 268 / 93

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

Сообщений: 990

31.05.2019, 13:43

4

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



0



0 / 0 / 0

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

Сообщений: 99

31.05.2019, 13:45

 [ТС]

5

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



0



370 / 268 / 93

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

Сообщений: 990

31.05.2019, 14:07

6

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

Решение

Проверьте



1



370 / 268 / 93

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

Сообщений: 990

31.05.2019, 14:08

7

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



0



0 / 0 / 0

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

Сообщений: 99

31.05.2019, 14:21

 [ТС]

8

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



0



370 / 268 / 93

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

Сообщений: 990

31.05.2019, 14:25

9

Добавил



1



Александр_80

0 / 0 / 0

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

Сообщений: 99

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



ArtNord

370 / 268 / 93

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

Сообщений: 990

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

Сообщений: 99

31.05.2019, 15:01

 [ТС]

12

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



0



ArtNord

370 / 268 / 93

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

Сообщений: 990

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

Сообщений: 99

31.05.2019, 15:04

 [ТС]

14

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



0



ArtNord

370 / 268 / 93

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

Сообщений: 990

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

Сообщений: 99

31.05.2019, 15:12

 [ТС]

16

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



0



ArtNord

370 / 268 / 93

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

Сообщений: 990

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

Сообщений: 99

31.05.2019, 15:16

 [ТС]

18

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



0



370 / 268 / 93

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

Сообщений: 990

31.05.2019, 15:17

19

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



1



0 / 0 / 0

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

Сообщений: 99

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

20

Копирование, с листа на лист (по нескольким условиям)

Max16

Дата: Среда, 01.06.2016, 16:18 |
Сообщение № 1

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

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

Сообщений: 11


Репутация:

0

±

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


Excel 2007

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

Суть проблемы следующая:
Есть массив информации на одном из листов книги (Area1), этот самый массив нужно преобразовать в итоговую таблицу, по заданным критериям (собака, кот, попугай), вид которой представлен на (Лист4). Файл прикладываю

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

Суть макроса, как мне представляется: создать итоговую таблицу, как у меня (в самом макросе задать переменные:

собака, кот, попугай, или вынести их на отдельный лист), и по этим переменным искать значения в исходном листе. После нахождения одной из переменных (f.e. собака) — макрос находил бы последнюю строку, добавлял следующей критерий (переменную), и по нему заполнял дальше массив. В общем нужен вид, как в прикрепленном файле. Думаю в нем будет понятнее

P.S. я возможно несколько наглею, прося о такой помощи. Поэтому не судите строго

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

2149532.xlsm
(28.5 Kb)


123

 

Ответить

wild_pig

Дата: Среда, 01.06.2016, 16:47 |
Сообщение № 2

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

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

Сообщений: 516


Репутация:

97

±

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


2003, 2013

Тут просто перенесли данные с одного листа на другой в соответствии с животинами. Это при условии совпадения столбцов с датами.
[vba]

Код

Sub uuu()
    ‘объявляем переменные
    Dim a() ‘динамический массив (пока что безразмерный)
    Dim i&, j&, rw& ‘длинные целые числа (счётчики)
‘——————-
    ‘присваиваем переменной значения диапазона с листа
    ‘массив сам примет нужные размеры
    a = Sheets(«Area1»).UsedRange.Value
    With Sheets(«Лист4») ‘ссылка на объект для упрощения синтаксиса
        ‘в пределах конструкции With … End With, если будет нужно ссылаться на «лист4» пишем точку
        For rw = 3 To .Cells(Rows.Count, 2).End(xlUp).Row ‘цикл от 3 до номера последней непустой ячейки во 2-м столбце
            If .Cells(rw, 2) <> «» Then ‘если значение ячейки не пусто то
                For i = 1 To UBound(a) ‘цикл по массиву от 1 до наибольшего индекса 1-го измерения массива (строки)
                    ‘сравниваем значение из массива со значением во 2-м столбце, ищем животное
                    If a(i, 1) = .Cells(rw, 2) Then ‘если значение элемента массива равно значению ячейки то
                        rw = rw + 1 ‘увеличиваем счётчик строк
                        For j = 1 To UBound(a, 2) ‘цикл от 1 до наибольшего индекса 2-го измерения массива (столбцы)
                            ‘вносим значения в соответствующие ячейки из массива на лист
                            .Cells(rw, j + 1) = a(i, j) ‘j + 1 потому что в массиве <=15 в 3-м столбце а на листе 4 в 4-м
                        Next
                    End If
                Next
            End If
        Next
    End With
    MsgBox «Фсё гуд!» ‘сообщеньице
End Sub

[/vba]

Сообщение отредактировал wild_pigЧетверг, 02.06.2016, 12:16

 

Ответить

Max16

Дата: Четверг, 02.06.2016, 10:45 |
Сообщение № 3

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

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

Сообщений: 11


Репутация:

0

±

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


Excel 2007

Уважаемый wild_pig, спасибо за помощь.

Но я к своему сожалению не до конца смог разобраться с Вашим макросом.
Я понял следующее:

[vba]

Код

Sub uuu()
‘задаем переменные массиву и значениям: i,j
    Dim a()                 
    Dim i&, j&
‘—————
‘задаем переменную a как массив (лист «Area1»)   
  a = Sheets(«Area1»).UsedRange.Value   

    ‘Задаем массив (с 3 строки 2 столбца до конца)для «Листа4»              
    With Sheets(«Лист4»)
        For rw = 3 To .Cells(Rows.Count, 2).End(xlUp).Row    

‘Если в заданном массиве ячейка не пуста, то      
If .Cells(rw, 2) <> «» Then     

       ‘Находим совпадение этой непустой ячейки на «Листе4» (с ячейкой на листе «Area1»)       
                For i = 1 To UBound(a)                   
                    If a(i, 1) = .Cells(rw, 2) Then

‘Далее. Строку принимаем равной (последняя строка +1)                    
                      rw = rw + 1                  
‘Вот тут я не совсем понимаю!!! Мы опять задаем массив для «Area1» для поиска 2-го значения?                      
                         For j = 1 To UBound(a, 2)       
‘Почему мы в качестве столбца задаем данные по строке (j)?              
                            .Cells(rw, j + 1) = a(i, j)                     
                        Next
                    End If
                Next
            End If
        Next
    End With
    MsgBox «Фсё гуд!»

[/vba]

Если Вы мне укажите, правильно ли я его (макрос) понимаю, буду признателен!
Ну и простите мою неграмотность в VBA — но насколько я знал, UBound считает предел по строке, но как я понимаю, здесь эта функция считает столбцы?


123

Сообщение отредактировал Max16Четверг, 02.06.2016, 11:02

 

Ответить

wild_pig

Дата: Четверг, 02.06.2016, 12:12 |
Сообщение № 4

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

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

Сообщений: 516


Репутация:

97

±

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


2003, 2013


Не совсем так )
Код выше поправил.

 

Ответить

Max16

Дата: Четверг, 02.06.2016, 12:58 |
Сообщение № 5

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

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

Сообщений: 11


Репутация:

0

±

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


Excel 2007

wild_pig, Большое спасибо за помощь). Благодаря Вам — разобрался


123

 

Ответить

Max16

Дата: Четверг, 02.06.2016, 18:50 |
Сообщение № 6

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

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

Сообщений: 11


Репутация:

0

±

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


Excel 2007

Уважаемый wild_pig, я уже замучил Вас… В любом случае Вы очень здорово меня выручили)
Но если Вам не трудно уделите немного внимания. Я доработал немного Ваш код, по аналогии, вынеся на отдельный лист критерии: кот, собака, попугай
Благодаря этому итоговая таблица формируется без пробелов, и удобно менять критерии. Но мне нужно вставить после каждого критерия (после всех котов, собак и попугаев), строку [итого:].
Я попытался ставить код в конце макроса, но он сначала формирует массив по заданным условиям и только потом ставит строку [итого]

Собственно вот подправленный макрос:
[vba]

Код

Sub uuu()
    Dim a()
    Dim b()
    Dim i&, j&, q&
‘—————
    a = Sheets(«Area1»).UsedRange.Value
    b = Sheets(«Критерий»).UsedRange.Value ‘присвоил переменное значение диапазону Лист:»Критерий»

          With Sheets(«Лист4»)
        For rw = 3 To .Cells(Rows.Count, 2).End(xlUp).Row
            If .Cells(rw, 2) <> «» Then
                For i = 1 To UBound(a)
                  For q = 1 To UBound(b) ‘цикл по массиву от 1 до наибольшего индекса 1-го измерения массива

                                    If a(i, 1) = b(q, 1) Then ‘Если значение элекмента массива («Area1») = значению элекмента массива («Критерий»), то
                        rw = rw + 1

                                                 For j = 1 To UBound(a, 2)
                            .Cells(rw, j + 1) = a(i, j)
                            .Cells(rw + 1, 2).FormulaR1C1 = «Итого:» ‘Пытался добавить строку [итого], но он ее добавляет после того как сформирует массив по критериям
                             Next
                        End If
                    Next
                Next
            End If
        Next
        Dim lLastRow As Long
       End With
    MsgBox «Фсё гуд!»
End Sub

[/vba]

Пример также прикладываю

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

8284379.xlsm
(25.0 Kb)


123

 

Ответить

wild_pig

Дата: Суббота, 04.06.2016, 13:05 |
Сообщение № 7

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

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

Сообщений: 516


Репутация:

97

±

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


2003, 2013

Нарисуйте ручками итоговую таблицу с итогами

 

Ответить

Max16

Дата: Суббота, 04.06.2016, 15:03 |
Сообщение № 8

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

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

Сообщений: 11


Репутация:

0

±

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


Excel 2007

Уважаемый wild_pig, таблицу необходимого вида я прикладываю к сообщению:

Область данных,та же (Area1)
Критерии [кот, собака, попугай] вынесены на отдельный лист (Лист!Критерии)
На листе4 — итоговая таблица. В начале имеем только строку 2 остальное подгружается макросом: Собственно таблица заполняется в соответствии с порядком расположения критериев

P.S. Итоговый вид таблицы, на листе4. Для наглядности я выделили красным цветом: критерий, синей заливкой: итого

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

7990798.xlsm
(23.1 Kb)


123

Сообщение отредактировал Max16Суббота, 04.06.2016, 15:04

 

Ответить

RAN

Дата: Суббота, 04.06.2016, 15:33 |
Сообщение № 9

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

Ранг: Экселист

Сообщений: 5645

Голимый макрорекордер
[vba]

Код

Sub Макрос1()
    ActiveSheet.UsedRange.Copy
    Sheets.Add(After:=Sheets(Sheets.Count)).Paste
    With ActiveSheet
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range(«A1»), _
                             SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .Sort.SetRange .UsedRange.Offset(1)
        .Sort.Header = xlGuess
        .Sort.MatchCase = False
        .Sort.Orientation = xlTopToBottom
        .Sort.SortMethod = xlPinYin
        .Sort.Apply
        .UsedRange.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(3, 4, 5, 6, _
                    7, 8, 9, 10), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
        .UsedRange.ClearOutline
    End With
End Sub

[/vba]


Быть или не быть, вот в чем загвоздка!

 

Ответить

wild_pig

Дата: Суббота, 04.06.2016, 16:01 |
Сообщение № 10

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

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

Сообщений: 516


Репутация:

97

±

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


2003, 2013

[vba]

Код

Sub uuu()
    Dim a(), b()
    Dim i&, ii&, rw&, x&, lr&
‘——————————
    ‘берём диапазоны в массивы
    a = Sheets(«Area1»).UsedRange.Value
    b = Sheets(«Критерий»).UsedRange.Value

        With Sheets(«Лист4»)
        rw = 3 ‘номер первой строки для выгрузки
        lr = .UsedRange.Rows.Count ‘номер последней строки диапазона
        If lr > 3 Then ‘если последняя строка больше первой  то
            .Rows(rw & «:» & lr).Delete ‘удаляем строки с первой по последнюю
        End If
        For i = 2 To UBound(b) ‘идём по массиву с критериями
            .Cells(rw, 2) = b(i, 1) ‘вносим название группы
            .Cells(rw, 2).Font.Bold = True ‘делаем жирным шрифт
            rw = rw + 1 ‘увеличиваем счётчик строк
            x = 1 ‘сбрасываем в начало счётчик позиций в группе
            For ii = 2 To UBound(a) ‘проходим по массиву с данными
                ‘если значение не пусто и совпадает с названием группы то
                If a(ii, 1) <> «» And a(ii, 1) = b(i, 1) Then
                    .Cells(rw, 1) = x ‘пишем номер позиции
                    For j = 1 To UBound(a, 2) ‘вносим строку из массива на лист
                        .Cells(rw, j + 1) = a(ii, j)
                    Next
                    rw = rw + 1 ‘увеличиваем счётчик строк
                    x = x + 1 ‘увеличиваем счётчик позиций
                End If
            Next
            .Cells(rw, 2) = «Итого » & LCase(b(i, 1)) & «:» ‘вносим итого
            .Cells(rw, 2).Font.Bold = True ‘делаем шрифт жирным
            rw = rw + 1 ‘увеличиваем счётчик строк
        Next
    End With
    MsgBox «Готово!» ‘радостная весть
End Sub

[/vba]
В Аrea1 нет значений больше 130 дней, зачем на Лист4 есть? Дальше будем думать что и как в итого считать?

 

Ответить

Max16

Дата: Суббота, 04.06.2016, 16:58 |
Сообщение № 11

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

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

Сообщений: 11


Репутация:

0

±

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


Excel 2007

wild_pig, большое спасибо)

Столбец >130 остался в примере из рабочего файла. В Area1 я просто не добавил дынные попадающие в данное условие.

По подсчету: если можно подсчитать в строке [итого] (на «листе4») сколько было котов, собак и попугаев. Это было бы очень здорово!

На всякий, прилепляю пример, как должен выглядеть подсчет

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

5988994.xlsm
(22.0 Kb)


123

 

Ответить

wild_pig

Дата: Суббота, 04.06.2016, 17:00 |
Сообщение № 12

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

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

Сообщений: 516


Репутация:

97

±

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


2003, 2013

Это было бы очень здорово!

Это был сарказм. Уже наверное сами.

 

Ответить

Max16

Дата: Суббота, 04.06.2016, 17:28 |
Сообщение № 13

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

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

Сообщений: 11


Репутация:

0

±

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


Excel 2007

wild_pig, да, пора и честь знать)))

Еще раз спасибо за помощь)


123

 

Ответить

wild_pig

Дата: Суббота, 04.06.2016, 17:39 |
Сообщение № 14

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

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

Сообщений: 516


Репутация:

97

±

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


2003, 2013

Вы #9 сообщение смотрели?

 

Ответить

Budkay91

Дата: Среда, 13.03.2019, 16:22 |
Сообщение № 15

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

Ранг: Прохожий

Сообщений: 2


Репутация:

0

±

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


Excel 2016

Здравствуйте, Господа!
Нужна помощь в написании макроса для excel 2016, для переноса ячеек с одного листа на другой, если выполняется условие.
Я в этом деле совсем начинающий, начальство нагибает закончить файл по спецодежде, а парень который начинал его делать уволился. Буду признателен!!! Очень сильно!!! SOS!!!
Для примера скидываю файлик «пример», в нем на листе «сотрудники», условие, если в столбце «Е» ячейки <= СЕГОДНЯ, то данная ячейка подсвечивается, это я допер. Теперь мне нужно с помощью макроса, чтобы тот сотрудник который подсветился автоматически попадал на лист «экзамен», помогите мне пожалуйста для примера, а свой глобальный файл я догоню доработаю!!! Заранее всем благодарен.

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

9569606.xlsm
(21.9 Kb)

 

Ответить

_Boroda_

Дата: Среда, 13.03.2019, 16:29 |
Сообщение № 16

Группа: Модераторы

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

Сообщений: 16618


Репутация:

6465

±

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


2003; 2007; 2010; 2013 RUS

— Прочитайте Правила форума
— Создайте свою тему согласно п.5q Правил форума
Эта тема закрыта


Скажи мне, кудесник, любимец ба’гов…
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995

 

Ответить

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


I have two sheets. One has the complete data and the other is based on the filter applied on the first sheet.

Name of the data sheet : Data
Name of the filtered Sheet : Hoky

I am just taking a small portion of data for simplicity. MY objective is to copy the data from Data Sheet, based on the filter. I have a macro which somehow works but its hard-coded and is a recorded macro.

My problems are:

  1. The number of rows is different everytime. (manual effort)
  2. Columns are not in order.

enter image description here
enter image description here

Sub TESTTHIS()
'
' TESTTHIS Macro
'
'FILTER
Range("F2").Select
Selection.AutoFilter
ActiveSheet.Range("$B$2:$F$12").AutoFilter Field:=5, Criteria1:="hockey"

'Data Selection and Copy
Range("C3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Hockey").Select
Range("E3").Select
ActiveSheet.Paste

Sheets("Data").Select
Range("D3").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hockey").Select
Range("D3").Select
ActiveSheet.Paste

Sheets("Data").Select
Range("E3").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hockey").Select
Range("C3").Select
ActiveSheet.Paste

End Sub

ashleedawg's user avatar

ashleedawg

20k8 gold badges73 silver badges104 bronze badges

asked Aug 24, 2016 at 11:21

Ananya Pandey's user avatar

Best way of doing it

Below code is to copy the visible data in DBExtract sheet, and paste it into duplicateRecords sheet, with only filtered values. Range selected by me is the maximum range that can be occupied by my data. You can change it as per your need.

  Sub selectVisibleRange()

    Dim DbExtract, DuplicateRecords As Worksheet
    Set DbExtract = ThisWorkbook.Sheets("Export Worksheet")
    Set DuplicateRecords = ThisWorkbook.Sheets("DuplicateRecords")

    DbExtract.Range("A1:BF9999").SpecialCells(xlCellTypeVisible).Copy
    DuplicateRecords.Cells(1, 1).PasteSpecial


    End Sub

answered Aug 22, 2017 at 1:46

Arpan Saini's user avatar

Arpan SainiArpan Saini

4,3641 gold badge38 silver badges50 bronze badges

1

I suggest you do it a different way.

In the following code I set as a Range the column with the sports name F and loop through each cell of it, check if it is «hockey» and if yes I insert the values in the other sheet one by one, by using Offset.

I do not think it is very complicated and even if you are just learning VBA, you should probably be able to understand every step. Please let me know if you need some clarification

Sub TestThat()

'Declare the variables
Dim DataSh As Worksheet
Dim HokySh As Worksheet
Dim SportsRange As Range
Dim rCell As Range
Dim i As Long

'Set the variables
Set DataSh = ThisWorkbook.Sheets("Data")
Set HokySh = ThisWorkbook.Sheets("Hoky")

Set SportsRange = DataSh.Range(DataSh.Cells(3, 6), DataSh.Cells(Rows.Count, 6).End(xlUp))
    'I went from the cell row3/column6 (or F3) and go down until the last non empty cell

    i = 2

    For Each rCell In SportsRange 'loop through each cell in the range

        If rCell = "hockey" Then 'check if the cell is equal to "hockey"

            i = i + 1                                'Row number (+1 everytime I found another "hockey")
            HokySh.Cells(i, 2) = i - 2               'S No.
            HokySh.Cells(i, 3) = rCell.Offset(0, -1) 'School
            HokySh.Cells(i, 4) = rCell.Offset(0, -2) 'Background
            HokySh.Cells(i, 5) = rCell.Offset(0, -3) 'Age

        End If

    Next rCell

End Sub

answered Aug 24, 2016 at 14:30

Rémi's user avatar

RémiRémi

3723 silver badges8 bronze badges

2

When i need to copy data from filtered table i use range.SpecialCells(xlCellTypeVisible).copy. Where the range is range of all data (without a filter).

Example:

Sub copy()
     'source worksheet
     dim ws as Worksheet
     set ws = Application.Worksheets("Data")' set you source worksheet here
     dim data_end_row_number as Integer
     data_end_row_number = ws.Range("B3").End(XlDown).Row.Number
    'enable filter
    ws.Range("B2:F2").AutoFilter Field:=2, Criteria1:="hockey", VisibleDropDown:=True
    ws.Range("B3:F" & data_end_row_number).SpecialCells(xlCellTypeVisible).Copy
    Application.Worksheets("Hoky").Range("B3").Paste
    'You have to add headers to Hoky worksheet
end sub

answered Aug 24, 2016 at 11:34

3

it needs to be .Row.count not Row.Number?

That’s what I used and it works fine
Sub TransfersToCleared()
Dim ws As Worksheet
Dim LastRow As Long
Set ws = Application.Worksheets(«Export (2)») ‘Data Source
LastRow = Range(«A» & Rows.Count).End(xlUp).Row
ws.Range(«A2:AB» & LastRow).SpecialCells(xlCellTypeVisible).Copy

answered Oct 6, 2020 at 18:09

Chunsah's user avatar

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.

cf5e0ebf6d62c9ec73df03c55f727e77.jpg

Download the attached file to get these examples in Excel.

Similar Content on TeachExcel

Activate or Navigate to a Worksheet using Macros VBA in Excel

Tutorial: Make a particular worksheet visible using a macro in Excel.
This is called activating a wo…

Get the Name of a Worksheet in Macros VBA in Excel

Tutorial: How to get the name of a worksheet in Excel using VBA and Macros and also how to store tha…

Get the Last Row using VBA in Excel

Tutorial:
(file used in the video above)
How to find the last row of data using a Macro/VBA in Exce…

Remove Dashed Lines from Copy Paste VBA in Excel

Tutorial: How to remove the flashing dashes from a copy/paste range using VBA in Excel; this removes…

Copy one range and paste in another range

Tutorial: Below is a macro, just copy and paste it into a module in your workbook and go from there…

Guide to Combine and Consolidate Data in Excel

Tutorial: Guide to combining and consolidating data in Excel. This includes consolidating data from …

Subscribe for Weekly Tutorials

BONUS: subscribe now to download our Top Tutorials Ebook!

Понравилась статья? Поделить с друзьями:
  • Макрос запустить одной кнопкой excel
  • Макрос книжка для word
  • Макрос запуск другого макроса excel
  • Макрос книги excel закрыть книгу
  • Макрос замены букв word