Добрый день! Есть табличка, в этой табличке есть данные. которые заполняются в ручную, далее выбирается фамилия ответственного, например ИВАНОВ. После на лист Иванова копируется, введенная раньше строка с введёнными данными ранее. Если мы выберем например Петров, то данная строка копируется на лист Петрова и так далее. При этом если заполняем уже другую строку, работает аналогичным способом. Как это реализовать, пытаюсь сообразить, но вразумительного ничего не приходит. Информации мало, да и ничего подходящего нет.
Добрый день! Есть табличка, в этой табличке есть данные. которые заполняются в ручную, далее выбирается фамилия ответственного, например ИВАНОВ. После на лист Иванова копируется, введенная раньше строка с введёнными данными ранее. Если мы выберем например Петров, то данная строка копируется на лист Петрова и так далее. При этом если заполняем уже другую строку, работает аналогичным способом. Как это реализовать, пытаюсь сообразить, но вразумительного ничего не приходит. Информации мало, да и ничего подходящего нет.flywithme1299
Sub u_67() Application.ScreenUpdating = False u = Cells(Rows.Count, "a").End(xlUp).Row For v = 2 To u w = Range("h" & v).Value x = Sheets(w).Cells(Rows.Count, "a").End(xlUp).Row + 1 Range("a" & v & ":b" & v).Copy Sheets(w).Range("a" & x) Range("d" & v & ":g" & v).Copy Sheets(w).Range("c" & x) Next Application.ScreenUpdating = True End Sub
[/vba]
[vba]
Код
Sub u_67() Application.ScreenUpdating = False u = Cells(Rows.Count, "a").End(xlUp).Row For v = 2 To u w = Range("h" & v).Value x = Sheets(w).Cells(Rows.Count, "a").End(xlUp).Row + 1 Range("a" & v & ":b" & v).Copy Sheets(w).Range("a" & x) Range("d" & v & ":g" & v).Copy Sheets(w).Range("c" & x) Next Application.ScreenUpdating = True End Sub
Nic70y, Замечательно, все работает. Но только если, например выберем Петрова, то у нас добавляется строка у Петрова, еще и у Иванова заново, то есть у Иванова будет уже две строки, а у Петрова одна строка. Но решение классное спасибо.
Nic70y, Замечательно, все работает. Но только если, например выберем Петрова, то у нас добавляется строка у Петрова, еще и у Иванова заново, то есть у Иванова будет уже две строки, а у Петрова одна строка. Но решение классное спасибо.flywithme1299
Сообщение отредактировал flywithme1299 - Четверг, 20.04.2023, 13:49
Sub u_67() Application.ScreenUpdating = False u = Cells(Rows.Count, "a").End(xlUp).Row For v = 2 To u w = Range("h" & v).Value x = Sheets(w).Cells(Rows.Count, "a").End(xlUp).Row + 1 y = Application.Match(Range("a" & v), Sheets(w).Range("a:a"), 0) If IsNumeric(y) = False Then Range("a" & v & ":b" & v).Copy Sheets(w).Range("a" & x) Range("d" & v & ":g" & v).Copy Sheets(w).Range("c" & x) End If Next Application.ScreenUpdating = True End Sub
[/vba]попробуйте
так [vba]
Код
Sub u_67() Application.ScreenUpdating = False u = Cells(Rows.Count, "a").End(xlUp).Row For v = 2 To u w = Range("h" & v).Value x = Sheets(w).Cells(Rows.Count, "a").End(xlUp).Row + 1 y = Application.Match(Range("a" & v), Sheets(w).Range("a:a"), 0) If IsNumeric(y) = False Then Range("a" & v & ":b" & v).Copy Sheets(w).Range("a" & x) Range("d" & v & ":g" & v).Copy Sheets(w).Range("c" & x) End If Next Application.ScreenUpdating = True End Sub
Sub u_67() Application.ScreenUpdating = False 'отключаем обновление экрана u = Cells(Rows.Count, "a").End(xlUp).Row 'нижняя заполненная строка For v = 2 To u 'пройдемся циклом от 2-й до нижней строки w = Range("h" & v).Value 'фамилия (лист загрузки) обрабатываемой строки x = Sheets(w).Cells(Rows.Count, "a").End(xlUp).Row + 1 'нижняя строка + 1 листа куда вставляем y = Application.Match(Range("a" & v), Sheets(w).Range("a:a"), 0) 'ищем номер в листе If IsNumeric(y) = False Then 'если номера нет, тогда копируем - вставляем данные Range("a" & v & ":b" & v).Copy Sheets(w).Range("a" & x) Range("d" & v & ":g" & v).Copy Sheets(w).Range("c" & x) End If Next Application.ScreenUpdating = True 'включаем обновление экрана End Sub
[/vba]
[vba]
Код
Sub u_67() Application.ScreenUpdating = False 'отключаем обновление экрана u = Cells(Rows.Count, "a").End(xlUp).Row 'нижняя заполненная строка For v = 2 To u 'пройдемся циклом от 2-й до нижней строки w = Range("h" & v).Value 'фамилия (лист загрузки) обрабатываемой строки x = Sheets(w).Cells(Rows.Count, "a").End(xlUp).Row + 1 'нижняя строка + 1 листа куда вставляем y = Application.Match(Range("a" & v), Sheets(w).Range("a:a"), 0) 'ищем номер в листе If IsNumeric(y) = False Then 'если номера нет, тогда копируем - вставляем данные Range("a" & v & ":b" & v).Copy Sheets(w).Range("a" & x) Range("d" & v & ":g" & v).Copy Sheets(w).Range("c" & x) End If Next Application.ScreenUpdating = True 'включаем обновление экрана End Sub
Nic70y, в новом файлике не отрабатывает снова правило, повторяется на других листах также:( И еще почему-то берется первая строка и добавляется на другой лист, а не последняя заполненная:(
Nic70y, в новом файлике не отрабатывает снова правило, повторяется на других листах также:( И еще почему-то берется первая строка и добавляется на другой лист, а не последняя заполненная:(flywithme1299
Sub A_1() Application.ScreenUpdating = False 'удаляем листы Application.DisplayAlerts = False For Each u In ThisWorkbook.Sheets If u.Index > 1 Then u.Delete Next Application.DisplayAlerts = True 'проходимся по фио a = Cells(Rows.Count, "j").End(xlUp).Row For b = 2 To a c = Sheets(1).Range("j" & b).Value 'фио d = Application.Match(c, Sheets(1).Range("j1:j" & b), 0) 'ищем первую строку с фио If b = d Then 'если фио встречается вперые Sheets.Add After:=Sheets(Sheets.Count) 'создаем лист Sheets(Sheets.Count).Name = c 'назовем его = фио 'копируем шапку.................................... Sheets(1).Range("a1:b1").Copy Sheets(c).Range("a1") Sheets(1).Range("d1:i1").Copy Sheets(c).Range("c1") End If 'копируем данные e = Sheets(c).Cells(Rows.Count, "a").End(xlUp).Row + 1 'строка вставки Sheets(c).Range("a" & e) = Sheets(1).Cells(b + 1, "a").End(xlUp).Value Sheets(c).Range("b" & e) = Cells(b + 1, "b").End(xlUp).Value Sheets(c).Range("c" & e & ":h" & e) = Sheets(1).Range("d" & b & ":i" & b).Value Next Application.ScreenUpdating = True End Sub
[/vba]
[vba]
Код
Sub A_1() Application.ScreenUpdating = False 'удаляем листы Application.DisplayAlerts = False For Each u In ThisWorkbook.Sheets If u.Index > 1 Then u.Delete Next Application.DisplayAlerts = True 'проходимся по фио a = Cells(Rows.Count, "j").End(xlUp).Row For b = 2 To a c = Sheets(1).Range("j" & b).Value 'фио d = Application.Match(c, Sheets(1).Range("j1:j" & b), 0) 'ищем первую строку с фио If b = d Then 'если фио встречается вперые Sheets.Add After:=Sheets(Sheets.Count) 'создаем лист Sheets(Sheets.Count).Name = c 'назовем его = фио 'копируем шапку.................................... Sheets(1).Range("a1:b1").Copy Sheets(c).Range("a1") Sheets(1).Range("d1:i1").Copy Sheets(c).Range("c1") End If 'копируем данные e = Sheets(c).Cells(Rows.Count, "a").End(xlUp).Row + 1 'строка вставки Sheets(c).Range("a" & e) = Sheets(1).Cells(b + 1, "a").End(xlUp).Value Sheets(c).Range("b" & e) = Cells(b + 1, "b").End(xlUp).Value Sheets(c).Range("c" & e & ":h" & e) = Sheets(1).Range("d" & b & ":i" & b).Value Next Application.ScreenUpdating = True End Sub
Nic70y, Тут создание новых листов, а тут нужно внедрить уже имеющийся в файл, да я убрал объединенные ячейки и начал без них. в итоге получается, что один раз только срабатывает на один лист, а дальше новые строки уже не добавляет:(
Nic70y, Тут создание новых листов, а тут нужно внедрить уже имеющийся в файл, да я убрал объединенные ячейки и начал без них. в итоге получается, что один раз только срабатывает на один лист, а дальше новые строки уже не добавляет:(flywithme1299
Nic70y, то есть если новую строку вписать на одного того же человека, то на его листе, допустим Иванова, будет замена первой строки произведена, а не добавлена новая:(
Nic70y, то есть если новую строку вписать на одного того же человека, то на его листе, допустим Иванова, будет замена первой строки произведена, а не добавлена новая:(flywithme1299
Nic70y, Устраивает, более подробно посмотрел его, работает так как надо, класс, а вот только еще заметил. один столбец не правильно заполняется № с/з, дата, там он вставляется вместо номеров
Nic70y, Устраивает, более подробно посмотрел его, работает так как надо, класс, а вот только еще заметил. один столбец не правильно заполняется № с/з, дата, там он вставляется вместо номеровflywithme1299
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
