Vba excel копирование строк по условию

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

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

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

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

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

1

2

3

4

5

6

7

8

9

10

11

12

13

14

15

16

17

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

    Next

End Sub

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

Dim c As Long

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

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

Cells(i, 1).Resize(1, c).Copy Cells(m, 1)
Источник
 

paha83

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

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

Доброго времени суток уважаемые форумчане!
Имею задачу которую не могу решить сам, из-за отсутствия знаний и навыков.
Исходные данные:
1. Несколько одинаковых по структуре листов (см. пример) 1, 2, 3;
2. Лист «Финиш».

Задача. С помощью VBA:
1. Скопировать строки из активнного листа либо1, либо 2… и вставить их на лист «Финиш».
Условия:
1. Копировать строки только при условии заполненной ячейки в столбце  «В»;
2. Скопированные строки должбыть вставлены как значения;
3. При копировании новых данных на лист «Финиш» они должны вставляться ниже старых;
4. Если в листе «Финиш» есть заполненные строки с копируемой датой, то старые затираются, а на их место становятся новые;
5. Перезаписать данные можно только в течении 1-го дня после указанной даты в листах 1, 2 …, либо при вводе пароля (скажем 143).

Спасибо!

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

  • Копия.xlsx (48.88 КБ)
 

CAHO

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

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

Пункт 3 и 4 противоречат друг другу. Или я не так понял.

Мастерство программиста не в том, чтобы писать программы, работающие без ошибок.
А в том, чтобы писать программы, работающие при любом количестве ошибок.

 

paha83

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

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

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

kakaccc

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

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

#4

22.09.2015 15:38:18

paha83

, если еще актуально:

Код 
Sub Copy_rows_if()
Dim currentRow As Integer
Dim sourceCol As Integer
Dim LastRow As Integer
Dim currentRowValue
Dim sourcews As String

sourcews = ActiveSheet.Name 'базовый лист
sourceCol = 2   'колонка B ключевая
RowCount = Cells(Rows.Count, sourceCol).End(xlUp).Row

For currentRow = 1 To RowCount  'для всех строк базового листа
    currentRowValue = Cells(currentRow, sourceCol).Value
    If Not (IsEmpty(currentRowValue) Or currentRowValue = "") Then
          Rows(currentRow).Copy
          Worksheets("Финиш").Select
          LastRow = Cells(Rows.Count, sourceCol).End(xlUp).Row
          Range(Cells(LastRow + 1, 1), Cells(LastRow + 1, 1)).PasteSpecial Paste:=xlPasteValues
          Worksheets(sourcews).Activate
    End If
Next
End Sub

Здесь первые 3 пункта.

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

  • Копия — копия.xlsm (54.39 КБ)

Изменено: kakaccc — 22.09.2015 18:11:32
 

kakaccc

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

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

#5

23.09.2015 15:35:13

Для 5 пункта:

Код 
Sub zashita_dannyh()
Dim currentRow As Integer
Dim sourceCol As Integer
Dim data As String

sourceCol = 2
RowCount = Cells(1, sourceCol).End(xlDown).Row
RowCount_2 = ActiveSheet.Cells(RowCount, sourceCol).End(xlDown).Row
data = Range(Cells(RowCount, sourceCol), Cells(RowCount, sourceCol)).Value

'проверка на ошибку
For currentRow = RowCount To RowCount_2 - 2
    currentRowValue = Cells(currentRow, sourceCol).Value
    If Not (IsEmpty(currentRowValue) Or currentRowValue = "") And _
    Cells(currentRow + 1, sourceCol).Value <> currentRowValue Then
        MsgBox ("даты на лите не совпадают")
        Exit Sub
    End If
Next

'протектим лист
If Date - DateValue(data) > 1 Then
ActiveSheet.Protect Password:="143" 'пароль 143
End If
End Sub

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

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

  • Копия — копия.xlsm (55.93 КБ)
 

paha83

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

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

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

kakaccc!

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

Еще раз спасибо!!!
 

rSkrin

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

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

Добрый день!
Друзья, знатоки Excel, подскажите пожалуйста решение проблемы, аналогичной вышеизложенной с небольшим усложнением. Требуется скопировать все строки таблицы ежедневного отчета, кроме шапки (т.е. начиная с 5-й строки), из листа «отчет» в лист «архив», ниже ранее скопированных, при условии заполнения  всех ячеек в столбце 5 (Е), т.е . достигнута полнота отчета. Если хоть одна ячейка в столбце 5 не заполнена не производить копирование на лист  «архив». И подскажите пожалуйста, возможно ли отображение строк на листе «архив», с рамками как в таблице на листе «отчет» или автоматическое добавление границ таблицы.
 

kakaccc

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

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

#8

27.02.2016 17:38:57

Код 
Sub copy_to_archive()

Dim currentRow As Integer
Dim sourceCol As Integer
Dim LastRow As Integer
Dim currentRowValue
Dim sourcews As String
Dim Rowsnum As Integer

sourcews = ActiveSheet.Name 'базовый лист
sourceCol = 5   'Ключевая E колонка
Set myTable = Worksheets(sourcews).Range("A1").CurrentRegion
Rowsnum = myTable.Rows.Count

For currentRow = 5 To Rowsnum  'проверяем есть ли пустые в 5-ой колонке
    currentRowValue = Cells(currentRow, sourceCol).Value
    If (IsEmpty(currentRowValue) Or currentRowValue = "") Then
    MsgBox ("Внимание! Есть пустые ячейки.")
    Exit Sub
    End If
Next

For currentRow = 5 To Rowsnum  'Копируем
    Rows(currentRow).Copy
    Worksheets("Архив").Select
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    With Range(Cells(LastRow + 1, 1), Cells(LastRow + 1, 1))
    .PasteSpecial Paste:=xlPasteValues
    .PasteSpecial Paste:=xlPasteFormats
    End With
    Worksheets(sourcews).Activate
Next
End Sub

Немного громоздкий макрос получился.
Ограничение такое: таблица должны начинаться с ячейки А1.
rSkrin, если сойдет, то потом откалибруем под ваши нужды.

Изменено: kakaccc — 28.02.2016 02:18:56
 

KuklP

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

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

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

#9

27.02.2016 18:36:24

kakaccc, чем по-Вашему будут отличаться результаты, если блок:

Код 
For currentRow = 5 To Rowsnum 'Копируем
 Rows(currentRow).Copy
 Worksheets("Архив").Select
 LastRow = Cells(Rows.Count, 1).End(xlUp).Row
 With Range(Cells(LastRow + 1, 1), Cells(LastRow + 1, 1))
 .PasteSpecial Paste:=xlPasteValues
 .PasteSpecial Paste:=xlPasteFormats
 End With
 Worksheets(sourcews).Activate
Next

записать так:

Код 
with Worksheets("Архив")
     LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
     myTable.offset(5).resize(myTable.Rows.Count-5).copy .Cells(LastRow + 1, 1)
end with

;)

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

 

TheBestOfTheBest

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

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

Excel 2010 +PLEX +SaveToDB +PowerQuery

Файл должен находиться в папке c:1. На таблице ПКМ-Обновить.

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

  • Копия.xlsx (57.41 КБ)

Неизлечимых болезней нет, есть неизлечимые люди.

 

kakaccc

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

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

KuklP, потому что я нуб в vba  :D

Спасибо! Буду теперь знать и использовать эту функцию.
Но хотел бы сначала разобраться. Объясни, пожалуйста, последнее действие: …copy .Cells(LastRow + 1, 1)
Как это работает? Это типа destination? К чему относится точка перед Cells() Почему, вообще, происходит вставка копируемого?
 

rSkrin

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

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

Спасибо друзья! Но есть вопрос. Уважаемый kakaccc, правильно ли я понял про «таблица должна начинаться с ячейки А1»- т.е.  начало всей таблицы, в том числе и шапки.  
 

rSkrin

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

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

Вопрос отменяю. Чуть подправил, проверил работу, все отлично!!! Спасибо.
 

KuklP

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

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

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

#14

28.02.2016 13:55:14

Цитата
kakaccc написал:
Это типа destination? К чему относится точка перед Cells()

Да, это destination.
выражением with Worksheets(«Архив») мы объявляем ссылку  на родительский объект Worksheets(«Архив»). дальше всему, что начинается с точки, вба будет пытаться присвоить родительский объект. Т.е. конструкцию

Код 
with Worksheets("Архив")
 LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
 myTable.offset(5).resize(myTable.Rows.Count-5).copy .Cells(LastRow + 1, 1)
end with

можно записать буквально:

Код 
 LastRow = Worksheets("Архив").Cells(Worksheets("Архив").Rows.Count, 1).End(xlUp).Row
 myTable.offset(5).resize(myTable.Rows.Count-5).copy Worksheets("Архив").Cells(LastRow + 1, 1)

в этом слуячае родительский объект вычисляется 3 раза вместо одного в предыдущем примере.
ВСЕ ЭТО и много другого интересного есть в справке по F1, причем составлено гораздо профессиональней и понятней чем в моем объяснении.

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

 

kakaccc

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

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

KuklP, все, раз это destination, то вопросов нет. Более менее разобрался. Буду теперь пользоваться. Красиво и лаконично получилось. Спасибо за объяснение!

rSkrin, да, вся таблица должна начинаться с А1 (шапка в вашемслучае). Можно сделать независимо от находжения таблицы, используя свойство CurrentRegion, например. Но тогда перед запуском макроса надо будет выделять какую-нибудь ячейку из таблицы. Первоначально я так и записал макрос. Не знал как для вас проще будет. Если хотите, можно так сделать.
 

0mega

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

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

#16

06.11.2022 11:54:18

KuklP

, здравствуйте

Цитата
KuklP написал:
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row

почему команда начинается с точки
LastRow = .Cells(.Rows …
Ранее Вы предоставили  «общепринятую «

Цитата
написал:
LastRow = Cells(Rows.Count, 1).End(xlUp).Row

Какое у них отличие ?
 

MikeVol

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

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

Ученик

#17

06.11.2022 12:29:09

0mega, Думаю если вы прочтёте справку то возможно поймёте что к чему.

почему команда начинается с точки
Источник
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

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
Источник

Копирование строк по условию

Ольга93

 Дата: Четверг, 25.04.2013, 21:15 |
Сообщение № 1

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

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

Сообщений: 8


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

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


Здравствуйте. Подскажите пожалуйста, как автоматически копировать строки из первого листа на новый (включая столбцы A-I), если в столбце J истина. Можно ли это сделать с помощью встроенных функций, или нужен макрос?
заранее спасибо smile

Сообщение отредактировал Ольга93 — Четверг, 25.04.2013, 23:14
 

Ответить

AlexM

 Дата: Четверг, 25.04.2013, 21:44 |
Сообщение № 2

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

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

Сообщений: 4257


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

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


Excel 2003

Цитата (Ольга93)

Можно ли это сделать с помощью встроенных функций

Нельзя

Цитата (Ольга93)

или нужен макрос

Нужен

Цитата (Ольга93)

автоматически копировать

Макрос с запуском по событию на листе
smile


Номер мобильного модема (без голосовой связи)
9269171249 МегаФон, Московский регион.

 

Ответить

Ольга93

 Дата: Четверг, 25.04.2013, 23:18 |
Сообщение № 3

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

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

Сообщений: 8


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

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


Спасибо

Сообщение отредактировал Ольга93 — Четверг, 25.04.2013, 23:19
 

Ответить

Ольга93

 Дата: Пятница, 26.04.2013, 09:08 |
Сообщение № 4

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

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

Сообщений: 8


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

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


А если не автоматически копировать?
 

Ответить

ShAM

 Дата: Суббота, 27.04.2013, 05:01 |
Сообщение № 5

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

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

Сообщений: 1347


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

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


Excel 2010

Может, ИНДЕКС и ПОИСКПОЗ помогут? Но это точно будет не «копирование».
 

Ответить

Ольга93

 Дата: Суббота, 27.04.2013, 20:58 |
Сообщение № 6

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

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

Сообщений: 8


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

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


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

Ответить

taxi_driver

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

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

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

Сообщений: 34


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

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


Ольга93, файл примера бы было не плохо, а то слово истина слишком широкое понятие
 

Ответить

AlexM

 Дата: Суббота, 27.04.2013, 21:06 |
Сообщение № 8

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

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

Сообщений: 4257


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

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


Excel 2003

Вы же к Сообщению №3 хотели добавить файл. Почему-то передумали. ???


Номер мобильного модема (без голосовой связи)
9269171249 МегаФон, Московский регион.

 

Ответить

Ольга93

 Дата: Суббота, 27.04.2013, 22:48 |
Сообщение № 9

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

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

Сообщений: 8


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

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


Файл прикрепляла несколько раз, пишет что прикреплено, но почему то не отображается:(
 

Ответить

Pelena

 Дата: Суббота, 27.04.2013, 22:51 |
Сообщение № 10

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

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

Сообщений: 18797


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

Замечаний:
±


Excel 2016 & Mac Excel

Цитата (Ольга93)

Файл прикрепляла несколько раз

Ольга93, Вы, наверное, Правила форума невнимательно прочитали

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

 

Ответить

Ольга93

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

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

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

Сообщений: 8


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

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


Пробую еще раз)

Сообщение отредактировал Ольга93 — Воскресенье, 28.04.2013, 00:01
 

Ответить

AlexM

 Дата: Воскресенье, 28.04.2013, 00:00 |
Сообщение № 12

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

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

Сообщений: 4257


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

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


Excel 2003

Файл должен быть до 100Кб


Номер мобильного модема (без голосовой связи)
9269171249 МегаФон, Московский регион.

 

Ответить

ShAM

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

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

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

Сообщений: 1347


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

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


Excel 2010

Пусть даже не Правила. Здесь же внизу (между «Прикрепить файл» и «Добавить ответ») все написано.
 

Ответить

Ольга93

 Дата: Воскресенье, 28.04.2013, 00:07 |
Сообщение № 14

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

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

Сообщений: 8


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

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


 

Ответить

AlexM

 Дата: Воскресенье, 28.04.2013, 00:21 |
Сообщение № 15

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

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

Сообщений: 4257


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

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


Excel 2003

Предполагаю, вы не смогли найти правила форума.
Рекомендации по составлению примера из правил.


Номер мобильного модема (без голосовой связи)
9269171249 МегаФон, Московский регион.

 

Ответить

Ольга93

 Дата: Воскресенье, 28.04.2013, 00:24 |
Сообщение № 16

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

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

Сообщений: 8


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

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


Хорошо, исправлюсь)

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

20_15.xls
(34.5 Kb)

Сообщение отредактировал Ольга93 — Воскресенье, 28.04.2013, 00:27
 

Ответить

ShAM

 Дата: Воскресенье, 28.04.2013, 01:25 |
Сообщение № 17

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

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

Сообщений: 1347


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

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


Excel 2010

Можно отфильтровать по ИСТИНЕ в столбце J. Потом выделяем нужный диапазон, жмем F5, Выделить, Только видимые ячейки, ОК.
Копируем, переходим на Лист1, вставляем. Убираем автофильтр.
Записал макрорекордером, немного подкорректировал и вот, что получилось:
[vba]

Код

Sub Макрос1()
Application.ScreenUpdating = False
       Dim LastRow As Long
       LastRow = Cells(Rows.Count, 10).End(xlUp).Row
       Range(«$A$2:$J$» & LastRow).AutoFilter Field:=10, Criteria1:=»ИСТИНА»
       Range(«A1:I» & LastRow).SpecialCells(xlCellTypeVisible).Copy Sheets(«Лист1»).[a1]
       Range(«A2:J» & LastRow).AutoFilter
Application.ScreenUpdating = True
End Sub

[/vba]

Сообщение отредактировал ShAM — Воскресенье, 28.04.2013, 01:36
 

Ответить

AlexM

 Дата: Воскресенье, 28.04.2013, 01:28 |
Сообщение № 18

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

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

Сообщений: 4257


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

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


Excel 2003

Вариант с формулой, в составе которой именованная формула.

Код

=ЕСЛИ(НИРиД<9^9;ИНДЕКС(НИР_20_15!$A$1:$I$1000;НИРиД;СТОЛБЕЦ(A1));»»)

Именованная формула НИРиД

Код

=НАИМЕНЬШИЙ(ИНДЕКС((НИР_20_15!$J$1:$J$1000<>ИСТИНА)*9^9+СТРОКА(НИР_20_15!$J$1:$J$1000););СТРОКА(НИР_20_15!A1))


Номер мобильного модема (без голосовой связи)
9269171249 МегаФон, Московский регион.

Сообщение отредактировал AlexM — Воскресенье, 28.04.2013, 01:35
 

Ответить

AlexM

 Дата: Воскресенье, 28.04.2013, 02:17 |
Сообщение № 19

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

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

Сообщений: 4257


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

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


Excel 2003

Еще вариант макроса


Номер мобильного модема (без голосовой связи)
9269171249 МегаФон, Московский регион.

Сообщение отредактировал AlexM — Воскресенье, 28.04.2013, 02:21
 

Ответить

Serge_007

 Дата: Воскресенье, 28.04.2013, 07:34 |
Сообщение № 20

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

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

Сообщений: 15894


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

Замечаний:
±


Excel 2016

Цитата (Ольга93)

пишет что прикреплено

Зачем обманывать? Нет на форуме такой опции (надписи при создании поста о том что файл прикреплён)

ЮMoney:41001419691823 | WMR:126292472390

 

Ответить
Источник

Sub Программа()

        Dim shSrc As Worksheet, arrSrc()
    Dim shRes As Worksheet, arrRes(), r As Long
    Dim strFN_src As String
    Dim lr As Long, i As Long

            ‘1. Юзер выбирает файл-источник.
    strFN_src = GetFilePath
    If strFN_src = «» Then Exit Sub

        ‘2. Отключение монитора, чтобы ускорить работу макроса и чтобы меньше мигало.
    Application.ScreenUpdating = False

        ‘3. Присваивание листу-результату имени «shRes». Затем через это имя удобно обращаться к листу в коде.
    Set shRes = ActiveSheet

        ‘4. Открытие файла-источника.
        ‘ Листу «свод» присваивается имя «shSrc».
        ‘ ReadOnly:=True — нам нужно открыть только для чтения. Это может чем-нибудь упростить макрос.
    Set shSrc = Workbooks.Open(Filename:=strFN_src, ReadOnly:=True).Worksheets(«свод»)

        ‘5. Копирование некоторых данных из листа-источника в массив. С массивом быстрее работать, чем с эксель-ячейками.
        ‘ На листе не должно быть скрытых строк, иначе некоторые строки могут быть не учтены.
    lr = shSrc.Cells(shSrc.Rows.Count, «A»).End(xlUp).Row
    arrSrc() = shSrc.Range(«A1:C» & lr).Value

        ‘6. Создание ячеек в массиве-результате. Сначала в него запишутся данные, а затем он
        ‘ будет вставлен на эксель-лист. Это ускорит работу макроса.
        ‘ Строк создаётся максимально возможное кол-во, т.к. заранее не известно, сколько будет строк с данными.
    ReDim arrRes(1 To UBound(arrSrc, 1), 1 To 3)

        ‘7. Копирование данных из листа-источника в массив-результат.
    For i = 5 To UBound(arrSrc, 1)
        If (arrSrc(i, 1) = 1) And (arrSrc(i, 3) = «ВСЕГО») Then
            r = r + 1
            arrRes(r, 1) = arrSrc(i, 1)
            arrRes(r, 2) = arrSrc(i, 2)
            arrRes(r, 3) = shSrc.Cells(i, «P»).Value
        End If
    Next i

        ‘8. Закрытие файла-источника.
    shSrc.Parent.Close SaveChanges:=False

        ‘9. Действия, если не было найдено нужных строк.
    If r = 0 Then
        Application.ScreenUpdating = True
        MsgBox «В файле-источнике нет нужных данных.», vbExclamation
        Exit Sub
    End If

        ’10. Вставка данных на лист-результат.
    shRes.Range(«A3»).Resize(r, UBound(arrRes, 2)).Value = arrRes()

        ’11. Включение монитора.
    Application.ScreenUpdating = True

        ’12. Сообщение, чтобы было понятно, что программа завершила работу.
    MsgBox «Готово.», vbInformation

    End Sub

Private Function GetFilePath() As String

        Const sTitle As String = «Выберите файл КДРО»
    Const sInitialPath As String = «c:»
    Const sFilterDescription As String = «Книги Excel»
    Const sFilterExtention As String = «*.xls*»

        With Application.FileDialog(msoFileDialogOpen)
        .ButtonName = «Выбрать»: .Title = sTitle: .InitialFileName = sInitialPath
        .Filters.Clear: .Filters.Add sFilterDescription, sFilterExtention

                If .Show = 0 Then Exit Function

                GetFilePath = .SelectedItems(1)

            End With

    End Function

[свернуть]

Источник

Понравилась статья? Поделить с друзьями:
  • Vba excel копирование строк на другой лист
  • Vba excel копирование папки
  • Vba excel копирование несвязанных диапазонов
  • Vba excel копирование на один лист
  • Vba excel копирование листа в новую книгу