Vba excel копирование данных по условию - Word и Excel - помощь в работе с программами

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

Условие задачи

Есть исходная таблица (набор данных) со списком файлов, расположенных в двух папках. Необходимо строки таблицы, содержащие слово «Изображения», скопировать в новую таблицу, расположенную ниже исходного набора данных, через одну пустую строку. В результате должно получиться, как на изображении ниже:

Решение задачи

Код VBA Excel для копирования строк исходного набора данных по условию в отдельную таблицу:

Sub KopirovaniyeStrok()

Dim s As String, n As Long, m As Long, i As Long

‘Задаем условие поиска

s = «Изображения»

‘Определяем номер последней строки исходной таблицы

n = Range(«A2»).CurrentRegion.Rows.Count

‘Задаем номер первой строки новой таблицы

m = n + 2

For i = 2 To n

‘Проверяем условие

If Cells(i, 1) = s Then

‘Копируем строку, удовлетворяющую условию, в новую таблицу

Cells(i, 1).Resize(1, 3).Copy Cells(m, 1)

m = m + 1

End If

End Sub

При желании, можно добавить в эту процедуру еще одну переменную и автоматическое определение количества столбцов:

Dim c As Long

c = Range(«A2»).CurrentRegion.Columns.Count

Тогда выражение копирования примет следующий вид:

Cells(i, 1).Resize(1, c).Copy Cells(m, 1)

Источник

somebox

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

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

06.06.2019 19:35:03

Знаю, что тема не новая, но никак не могу решить проблему. Есть код:

Код

Private Sub CommandButton1_Click()
    Dim i As Integer
    Dim country As Variant
    Dim countryList As Range
    i = 0
    country = TextBox1.Value
    Set countryList = Worksheets("Лист2").Range("C1").End(xlDown)
    For Each Cell In countryList
        If Cell.Value = country Then
            Cell.Offset(0, -2).Value = Worksheets("Лист1").Cells(1 + i, 1).Value
            Cell.Offset(0, -1).Value = Worksheets("Лист1").Cells(1 + i, 2).Value
        End If
        i = i + 1
    Next
End Sub

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

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

country.xlsm (20.32 КБ)

skais675

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

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

06.06.2019 20:02:23

Для начала это неверно. Вам проще описать что нужно, так как из кода не совсем понятно.

Код
Set countryList = Worksheets("Лист2").Range("C1").End(xlDown)

Изменено: skais675 — 06.06.2019 20:04:14

Мой канал

somebox Пользователь Сообщений: 64 Регистрация: 02.02.2014

skais675 Пользователь Сообщений: 2177 Регистрация: 03.06.2014	Я уже сказал, опишите задачу, потому как догадываться нет желания.

somebox

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

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

Так я ж написал. Нужно, чтобы программа отобрала значения из первых двух столбцов таблицы со второго листа по условию, находящемуся в третьем столбце. После составила из них новую таблицу на первом листе. Например, я указываю в открывшемся окне слово «Англия», и программа копирует все значения из таблицы, касаемо Англии.

skais675

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

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

06.06.2019 20:15:00

Ну ну. Теперь найдите — сколько отличий?

Код

Private Sub CommandButton1_Click()
    Dim i As Integer
    Dim country As Variant
    Dim countryList As Range
    i = 0
    country = TextBox1.Value
    With Sheets("Лист2")
        Set countryList = .Range("C1:C" & .Cells(.Rows.Count, "C").End(xlUp).Row)
    End With
    For Each Cell In countryList
        If Cell.Value = country Then
            Sheets("Лист1").Cells(1 + i, 1) = Cell.Offset(0, -2)
            Sheets("Лист1").Cells(1 + i, 2) = Cell.Offset(0, -1)
            i = i + 1
        End If
    Next
End Sub

Изменено: skais675 — 06.06.2019 20:16:38

Мой канал

somebox

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

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

06.06.2019 20:27:13

А почему не работал предыдущий Range?

Код
With Sheets("Лист2") Set countryList = .Range("C1:C" & .Cells(.Rows.Count, "C").End(xlUp).Row) End With

должен быть таким сложным, с таким количеством вложений (и Cells, и Rows.Count, и End)? Я пытаюсь понять, как я должны был сам до такой конструкции додуматься.

Изменено: somebox — 06.06.2019 20:28:02

skais675 Пользователь Сообщений: 2177 Регистрация: 03.06.2014	somebox Наберитесь терпения и изучите тему определения последней ячейки. Ну соответственно диапазона. Методик несколько — каждая имеет свои нюансы.

somebox Пользователь Сообщений: 64 Регистрация: 02.02.2014	Да вроде уже читал все эти инструкции, но посмотрю еще. Видимо, что-то упустил. За код спасибо. Работает.

somebox

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

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

#10

06.06.2019 21:22:01

Хотя нет. Работает, да не так. Поторопился я.

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

Код
Sheets("Лист1").Cells(1 + i, 1).Value = Cell.Offset(0, -2).Value Sheets("Лист1").Cells(1 + i, 2).Value = Cell.Offset(0, -1).Value

Предполагалось, что будет создаваться новая таблица из избранных значений, а они просто копируются «как есть».

Все. Нашел ошибку. Надо было i = i + 1 поставить в блок If.

Изменено: somebox — 06.06.2019 21:46:39

Источник

Option Explicit         ' Обязательное объявление переменных
Option Compare Text     ' отсутствие чувствительности к регистру при сравнении символов
 
Sub Raspredelenie_po_listam()
    Const FirstRow& = 7 ' Константа - первая строка данных ниже шапки на всех листах
    Dim i&, j&, LastRow&, LastRowTarget&, ShName, Sh_Target As Worksheet, Prefix$, FormulaRC$, A
    Application.ScreenUpdating = False ' Временное отключение обновления экрана в Excel
    For Each ShName In Array("Лист2", "Лист3", "Лист4") ' Цикл по 3 листам с результатами для очистки старых данных
        With Sheets(ShName) ' Работа с объектом Sheet через символ "."
            LastRowTarget = .Cells(.Rows.Count, "Z").End(xlUp).Row ' Определение последней заполненной строки по столбцу Z
            If LastRowTarget < FirstRow Then LastRowTarget = FirstRow  ' последняя заполненная строка не должна быть меньше FirstRow  (=7)
            .Rows(FirstRow & ":" & LastRowTarget).Clear    ' Удаление строк со старыми данными при новом распределении
        End With
    Next ShName
    With Лист1 ' Работа с объектом Лист1 (программное имя объекта) через символ "."
        LastRow = .Cells(.Rows.Count, "Z").End(xlUp).Row  ' Определение последней заполненной строки по столбцу Z
        Prefix = "=" & Лист1.Name & "!R" ' Первая часть ссылочных формул
        A = .Range(.Cells(1, 1), .Cells(LastRow, 15)).Value ' Формируем массив для проверки условий
        For i = FirstRow To LastRow ' Цикл по строкам анализируемого листа
            A(i, 8) = Trim(A(i, 8)) ' удаление пробелов спереди и сзади в элементах 8-го столбца массива
            A(i, 15) = Trim(A(i, 15))
            If A(i, 8) = "ЗБС" Or A(i, 8) = "ВНС" Then ' Комплекс условий 1
                Set Sh_Target = Лист2 ' Объектная ссылка на лист цель.
            ElseIf (A(i, 8) = "Конс" Or A(i, 8) = "Раск") And A(i, 15) = "Я" Then ' Комплекс условий 2
                Set Sh_Target = Лист3 ' Объектная ссылка на лист цель.
            Else ' если не выполняется ни 1-ый ни 2-ой комлекс условий
                Set Sh_Target = Лист4 ' Объектная ссылка на лист цель.
            End If
            .Range(.Cells(i, 1), .Cells(i, "AU")).Copy  ' копирование  i-той строки (по AU,для последующей вставки форматов)
            FormulaRC = Prefix & Format(i) & "C"  ' 2-я часть ссылочной формулы
            With Sh_Target '  Работа с объектом листом-целью, куда копируем форматы, через символ "."
                 LastRowTarget = .Cells(.Rows.Count, "Z").End(xlUp).Row + 1 ' Определение последней пустой строки по столбцу Z
                 If LastRowTarget < FirstRow Then LastRowTarget = FirstRow
                .Cells(LastRowTarget, 1).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False ' вставка скопированных форматов
                .Rows(LastRowTarget).RowHeight = Лист1.Rows(i).RowHeight ' Выравнивание высоты строки по исходной
                .Range(.Cells(LastRowTarget, 1), .Cells(LastRowTarget, "AU")).FormulaR1C1 = FormulaRC  ' заполнение целевого диапазона ссылочными формулами
            End With
        Next i
    End With
    Set Sh_Target = Nothing ' Очистка памяти от объектных ссылок
End Sub

Источник

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

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

Ответить

Источник

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:

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

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

20k8 gold badges73 silver badges104 bronze badges

asked Aug 24, 2016 at 11:21

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 SainiArpan Saini

4,3541 gold badge38 silver badges50 bronze badges

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émiRémi

3723 silver badges8 bronze badges

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

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

Источник