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 |
|
Яна Жилак Пользователь Сообщений: 51 |
Есть ячейка «F» в листе1 если в ней стоит флажок, нужно чтобы вся строка копировалась на лист2 в пустую строку Изменено: Яна Жилак — 26.12.2012 13:58:21 |
|
Юрий М  Модератор Сообщений: 60585 Контакты см. в профиле |
|
|
Яна Жилак Пользователь Сообщений: 51 |
|
|
Chyma Пользователь Сообщений: 117 |
А как сделать так, чтобы в столбце F при выделении ячейки появлялся/исчезал флажок? Изменено: Chyma — 26.12.2012 14:25:44 |
|
Яна Жилак Пользователь Сообщений: 51 |
#5 26.12.2012 14:23:26
Одним нажатием левой кнопки мышки Изменено: Яна Жилак — 27.12.2013 15:05:30 |
||
|
Юрий М Модератор Сообщений: 60585 Контакты см. в профиле |
|
|
Юрий М Модератор Сообщений: 60585 Контакты см. в профиле |
Там ещё нужно немного исправить диапазон: |
|
Chyma Пользователь Сообщений: 117 |
Юрий М, я хотел узнать вот про этот прием . Изменено: Chyma — 26.12.2012 14:38:29 |
|
Яна Жилак Пользователь Сообщений: 51 |
Юрий еще один вопросик. |
|
Юрий М Модератор Сообщений: 60585 Контакты см. в профиле |
Для этого нужно прогнать птиц. |
|
Юрий М Модератор Сообщений: 60585 Контакты см. в профиле |
#11 26.12.2012 14:32:33
Я про ЭТО и ответил. |
||
|
Яна Жилак Пользователь Сообщений: 51 |
Пропишите пожалуйста в макросе какая строчка за что отвечает,для того чтобы адаптировать под свою таблицу. |
|
Юрий М Модератор Сообщений: 60585 Контакты см. в профиле |
|
|
Яна Жилак Пользователь Сообщений: 51 |
#14 26.12.2012 15:17:10
Дело в том что, есть необходимость менять вторую страницу по запросу и нужно чтобы при снятии галочки со строки ее не было бы на 2 странице,это возможно? |
||
|
Юрий М Модератор Сообщений: 60585 Контакты см. в профиле |
Яна, сколько ЕЩЁ козырей у Вас в рукаве? |
|
Яна Жилак Пользователь Сообщений: 51 |
#16 26.12.2012 15:23:37
Да,но если на этой строке один раз стояла галка,то эта строка будет находится на второй странице и автоматически ее не уберешь?Только вручную удалять? |
||
|
Юрий М Модератор Сообщений: 60585 Контакты см. в профиле |
У Вас изначально была задача ДОБАВЛЯТЬ отмеченную строку в первую свободную на втором листе. А теперь Вы ставите совсем ДРУГУЮ задачу — переписывать ВСЁ на втором листе. И макрос тут нужен другой. |
|
Яна Жилак Пользователь Сообщений: 51 |
Извините,спасибо за помощь! |
|
Hugo Пользователь Сообщений: 23253 |
Я похожие задачи делал по такому алгоритму — по событию перехода на второй лист там макросом заново формируются все данные по условиям с первого листа. |
|
Юрий М Модератор Сообщений: 60585 Контакты см. в профиле |
Ну да — очистить диапазон и заново всё заполнить. |
|
Юрий М Модератор Сообщений: 60585 Контакты см. в профиле |
Версия 3 |
|
Яна Жилак Пользователь Сообщений: 51 |
|
|
Яна Жилак Пользователь Сообщений: 51 |
Юрий все конечно супер, но я к сожалению не смогла адаптировать Ваш макрос под свою таблицу(Не могли бы Вы мне помочь? |
|
Юрий М Модератор Сообщений: 60585 Контакты см. в профиле |
Убегаю на пару часов… Если никто не поможет — сделаю вечером. |
|
Юрий М Модератор Сообщений: 60585 Контакты см. в профиле |
Яна, у Вас несоответствие структуры таблиц на листах «Акт Приемки1» и «Акт Разгрузки». Приведите их к едином у виду. И зачем там вообще объединённые ячейки? |
|
Яна Жилак Пользователь Сообщений: 51 |
Объединенные ячейки потому как, так формирует база 1С.В таблице я пометила желтым цветом то что нужно переносить в какую ячейку.Извините что так долго Вас мучаю(((((Самой уже как то неудобно( Изменено: Яна Жилак — 27.12.2013 15:01:31 |
|
Юрий М Модератор Сообщений: 60585 Контакты см. в профиле |
Копировать нужно с листа Акт Приемки1 на лист Акт Разгрузки? И где там жёлтое? Я так понял, что скопировать нужно четыре строки, помеченный галкой? Копировать по кнопке или автоматом? Что будете делать, если отмеченных строк будет больше, чем для них отведено место на бланке? |
|
Яна Жилак Пользователь Сообщений: 51 |
Прошу прощения ни тот файл отправила |
|
Юрий М Модератор Сообщений: 60585 Контакты см. в профиле |
Отмечено 5, скопировано 4 — почему? |
|
Яна Жилак Пользователь Сообщений: 51 |
#30 27.12.2012 10:39:41 Копировать нужно нажав на кнопку «Несоответствия» |
Копирование строк по условию из существующего набора данных в отдельную таблицу с помощью кода 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) |
автоматическое копирование данных по условию
Автор gitzzz, 25.07.2009, 14:22
« назад — далее »
Добрый день.
Столкнулся с проблемой:
Есть 2 листа. В первом основные данные. Есть призначное поле (да/нет).
Нужно, чтобы при вводе данных в таблицу (когда это поле = «да») автоматически копировалась на второй лист нужная инфа из этой строки данных.
Такие возможности ехсел не знаю, но знаю что они есть)
Подскажите, пожалуйста, как это можно организовать (оперативно)?
Пробовал с помощью ЕСЛИ() но там постоянно выдается ответ ЛОЖЬ. Может макрос какой-нибудь есть?
Заранее, спасибо.
Есть несколько путей:
1. Написать макрос, который будет копировать на свободное место на втором листе значение, введенное в ячейку на первом листе, если рядом ввели признак ДА. Сам я макрос написать не возьмусь, но знаю, что это не обчень сложно. Попробуйте сами использовать макрорекодер для записи собственных действий, а потом поправьте макрос.
2. Использовать сводную таблицу. Опять таки, сам никогда их не использовал, но другим людям нравится.
3. Записать во второй таблице формулы, отображающие значения всех строк (ячеек), содержащий признак ДА.
Проще всего это сделать с помощью дополнительного столбца в первой таблице:
Пусть на листе 1 значения записываются в столбце A, признаки храняться в столбце B.
Тогда в ячейке C1 запишем формулу (и протянем ее по всему столбцу C): =ЕСЛИ(B1=»ДА»;СТРОКА();»»)
После этого переходим на лист 2 и в ячейке A1 записываем формулу (и также протягиваем ее вниз на столько сколько нужно):
=ЕСЛИ(СТРОКА()>СЧЁТ(Лист1!C:C);»»;ИНДЕКС(Лист1!A:A;НАИМЕНЬШИЙ(Лист1!C:C;СТРОКА());1))
Если нужно перенести значения из нескольких столбцов первого листа, то нужно записать несколько формул, поправив агрументы функции ИНДЕКС().
P.S. Важно, чтобы в столбце C первого листа не было лишних цифровых значений.
Если у Вас на листах должна быть шапка, то поэкспериментируйте с добавлений констант вида: СТРОКА()-Const
Нашел интересную статью, но опять возникли трудности с реализацией:
http://stockportal.ru/extrading/archives/225
Помогите разобраться в части кода, начиная с Call QuoteRead(intInstCount)
Кстати та книгде и не наше что это за функция…
Код можно переделать под мою задачу, или это вобще чтото другое?…
Public WithEvents App As Application
Private Sub App_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim pRow As Integer, pCol As Integer, intRow As Integer, I As Integer, intInstCount As Integer
Dim pValue As Variant
Dim wInstSheet As Worksheet
Dim wNVSheet As Worksheet
Set wInstSheet = Application.Workbooks("NettoVolume.xlsm").Sheets("Instruments")
Set wNVSheet = Application.Workbooks("NettoVolume.xlsm").Sheets("NV")
intInstCount = wInstSheet.Cells(2, 5)
If Sh.Name = "Котировки" And Target.Column > 1 And Target.Row > 1 And Target.Row < 10 Then
Debug.Print "Вошел в AppEvents"
Call QuoteRead(intInstCount)
For I = 1 To intInstCount
If Instruments(I).ChangeMode = 2 Then
intRow = wInstSheet.Cells(3, 5) + 1
Call Instruments(I).Output(wNVSheet, intRow, 2)
wInstSheet.Cells(3, 5) = intRow
End If
Next I
End If
End Sub
Сводную таблу сделал, но ее обновлять надо, да и пустые значения фильтром убираются…Не автоматизированно всё… Хочется, чтобы все обрабатывалось динамически.
Может кто-н знает как обработать событие при изменении значений в ячейке? Подскажите, пожалуйста. Код так и не смог разобрать…..
Если в ячейке «А1» написать слово ИСТИНА, а нижеследующий код скопировать в модуль листа №1, то, при изменении любой одной ячейки второго столбца, третьи столбцы двух листов этой строки «синхронизируются».
Private Sub Worksheet_Change(ByVal Target As Range)
With Target
If .Count > 1 Then Exit Sub
If .Column = 2 And [A1] Then Sheets(2).Cells(.Row, 3) = .Offset(0, 1)
End With
End Sub
Знания недостаточно, необходимо применение. Желания недостаточно, необходимо действие. (с) Брюс Ли
- Профессиональные приемы работы в Microsoft Excel
-
►
Обмен опытом -
►
Microsoft Excel -
►
автоматическое копирование данных по условию
Кому нужно будет забирайте, правда нужно будет укоротить его.
Кто может помогите оптимизировать….
Sub ОставитьТолько707и747()
Dim ra As Range, delra As Range
Application.ScreenUpdating = False ‘ отключаем обновление экрана
Range(«A1»).Select
‘ ищем и удаляем ячейки, содержащие заданный текст
‘ (можно указать сколько угодно значений, и использовать подстановочные знаки)
УдалятьЯчейкиСТекстом = Array(«?727???????», _
«?700???????», _
«?701???????», _
«?702???????», _
«?703???????», _
«?704???????», _
«?705???????», _
«?706???????», _
«?708???????», _
«?709???????», _
«?750???????», _
«?751???????», _
«?760???????», _
«?761???????», _
«?762???????», _
«?763???????», _
«?764???????», _
«?771???????», _
«?775???????», _
«?776???????», _
«?777???????», _
«777???????», _
«?771???????»)
‘ перебираем все строки в используемом диапазоне листа
For Each ra In ActiveSheet.UsedRange.Cells
‘ перебираем все фразы в массиве
For Each word In УдалятьЯчейкиСТекстом
‘ если в очередной ячейке листа найден искомый текст
If Not ra.Find(word, , xlValues, xlPart) Is Nothing Then
‘ добавляем ячейку в диапазон для удаления
If delra Is Nothing Then Set delra = ra Else Set delra = Union(delra, ra)
End If
Next word
Next
‘ если подходящие ячейки найдены, то: (удаляем)
If Not delra Is Nothing Then delra.Value = «»
End Sub