Доброго всем времени уважаемые!!! Пытаюсь по заданию начальства сделать файлик для контроля выполнения и учета суточных заданий цеха. Почти все сделал, но осталась одна задача, которая мне пока не по силам. . На листе ФРЗ.ОЦ при установке любого значения в диапазоне I4:I74 строчка перемещается на Лист сводная. Это реализовано. А вот как перенести оставшиеся строчки вверх на освободившееся место? Причем перенос делается только в пределах 8 строчек, ограниченных желтыми строчками. вот макрос
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim dat&, per& per = ThisWorkbook.Sheets("сводная").Cells(Rows.Count, 1).End(xlUp).Row + 1 dat = Cells(Rows.Count, 4).End(xlUp).Row If Target.Count > 1 Then Exit Sub If Not Intersect(Target, Range("I4:I" & dat)) Is Nothing Then Target.Offset(0, -6).Resize(1, 5).Copy ThisWorkbook.Sheets("сводная").Activate ActiveSheet.Range("A" & per).PasteSpecial Selection.FormatConditions.Delete ThisWorkbook.Sheets("сводная").Range("F" & per).Value = Date ThisWorkbook.Sheets("сводная").Range("F" & per).Borders.LineStyle = xlContinuous ThisWorkbook.Sheets("ФРЗ.ОЦ").Activate Target.Offset(0, -5).Resize(1, 6).ClearContents End If End Sub
[/vba]
и файл
Доброго всем времени уважаемые!!! Пытаюсь по заданию начальства сделать файлик для контроля выполнения и учета суточных заданий цеха. Почти все сделал, но осталась одна задача, которая мне пока не по силам. . На листе ФРЗ.ОЦ при установке любого значения в диапазоне I4:I74 строчка перемещается на Лист сводная. Это реализовано. А вот как перенести оставшиеся строчки вверх на освободившееся место? Причем перенос делается только в пределах 8 строчек, ограниченных желтыми строчками. вот макрос
[vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim dat&, per& per = ThisWorkbook.Sheets("сводная").Cells(Rows.Count, 1).End(xlUp).Row + 1 dat = Cells(Rows.Count, 4).End(xlUp).Row If Target.Count > 1 Then Exit Sub If Not Intersect(Target, Range("I4:I" & dat)) Is Nothing Then Target.Offset(0, -6).Resize(1, 5).Copy ThisWorkbook.Sheets("сводная").Activate ActiveSheet.Range("A" & per).PasteSpecial Selection.FormatConditions.Delete ThisWorkbook.Sheets("сводная").Range("F" & per).Value = Date ThisWorkbook.Sheets("сводная").Range("F" & per).Borders.LineStyle = xlContinuous ThisWorkbook.Sheets("ФРЗ.ОЦ").Activate Target.Offset(0, -5).Resize(1, 6).ClearContents End If End Sub
китин, Добрый день. А между желтыми строчками всегда будет так? в смысле и пусты и заполненные строчки или все же должно быть в итоге оставаться только заполненные?
китин, Добрый день. А между желтыми строчками всегда будет так? в смысле и пусты и заполненные строчки или все же должно быть в итоге оставаться только заполненные?and_evg
Добрый! Да всегда. То есть смысл такой: центру дается дневное задание ( максимально 8 деталей) мастер заполняет эти строчки ( от 1 детали до 8) . по мере готовности детали он ставит еденичку в столбец I напротив этой сделанной детали и вся строчка переносится на лист Сводная. на листе ФРЗ.ОЦ эта строчка очищается. хотелось бы, что бы еще существующие строчки перемещались вверх на освободившиеся строки.( То есть: осталсь 2 детали и они д.б. на верхних двух строчках)
Добрый! Да всегда. То есть смысл такой: центру дается дневное задание ( максимально 8 деталей) мастер заполняет эти строчки ( от 1 детали до 8) . по мере готовности детали он ставит еденичку в столбец I напротив этой сделанной детали и вся строчка переносится на лист Сводная. на листе ФРЗ.ОЦ эта строчка очищается. хотелось бы, что бы еще существующие строчки перемещались вверх на освободившиеся строки.( То есть: осталсь 2 детали и они д.б. на верхних двух строчках)китин
Не судите очень строго:я пытаюсь научиться ЯД 41001877306852
Private Sub Worksheet_Change(ByVal Target As Range) Dim dat&, per& per = ThisWorkbook.Sheets("сводная").Cells(Rows.Count, 1).End(xlUp).Row + 1 dat = Cells(Rows.Count, 4).End(xlUp).Row If Target.Count > 1 Then Exit Sub If Not Intersect(Target, Range("I4:I" & dat)) Is Nothing Then Target.Offset(0, -6).Resize(1, 5).Copy ThisWorkbook.Sheets("сводная").Activate ActiveSheet.Range("A" & per).PasteSpecial Selection.FormatConditions.Delete ThisWorkbook.Sheets("сводная").Range("F" & per).Value = Date ThisWorkbook.Sheets("сводная").Range("F" & per).Borders.LineStyle = xlContinuous ThisWorkbook.Sheets("ФРЗ.ОЦ").Activate Rows(Target.Row).Select Selection.Delete Shift:=xlUp ' Target.Offset(0, -5).Resize(1, 6).ClearContents End If End Sub
[/vba]
Если правильно понял: [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim dat&, per& per = ThisWorkbook.Sheets("сводная").Cells(Rows.Count, 1).End(xlUp).Row + 1 dat = Cells(Rows.Count, 4).End(xlUp).Row If Target.Count > 1 Then Exit Sub If Not Intersect(Target, Range("I4:I" & dat)) Is Nothing Then Target.Offset(0, -6).Resize(1, 5).Copy ThisWorkbook.Sheets("сводная").Activate ActiveSheet.Range("A" & per).PasteSpecial Selection.FormatConditions.Delete ThisWorkbook.Sheets("сводная").Range("F" & per).Value = Date ThisWorkbook.Sheets("сводная").Range("F" & per).Borders.LineStyle = xlContinuous ThisWorkbook.Sheets("ФРЗ.ОЦ").Activate Rows(Target.Row).Select Selection.Delete Shift:=xlUp ' Target.Offset(0, -5).Resize(1, 6).ClearContents End If End Sub
мдя. все оказывается не так просто. Если ставить 1 в первой восьмерке на второй строчке, то удаляется эта вторая строчка. а добавляется во вторую восьмерку. и в первой восьмерке 7 строк а во второй 9
мдя. все оказывается не так просто. Если ставить 1 в первой восьмерке на второй строчке, то удаляется эта вторая строчка. а добавляется во вторую восьмерку. и в первой восьмерке 7 строк а во второй 9китин
Private Sub Worksheet_Change(ByVal Target As Range) Dim dat&, per& dat = Cells(Rows.Count, 4).End(xlUp).Row If Target.Count > 1 Then Exit Sub If Not Intersect(Target, Range("I4:I" & dat)) Is Nothing Then With ThisWorkbook.Sheets("сводная") per = .Cells(Rows.Count, 1).End(xlUp).Row + 1 Target.Offset(0, -6).Resize(1, 5).Copy .Range("A" & per) .Range("A" & per).Resize(1, 5).FormatConditions.Delete With .Range("F" & per) .Value = Date: .Borders.LineStyle = xlContinuous End With End With Target.Offset(0, -6).Resize(1, 7).Delete xlUp End If End Sub
[/vba]
Игорь, как вариант, в файле не пробовал: [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim dat&, per& dat = Cells(Rows.Count, 4).End(xlUp).Row If Target.Count > 1 Then Exit Sub If Not Intersect(Target, Range("I4:I" & dat)) Is Nothing Then With ThisWorkbook.Sheets("сводная") per = .Cells(Rows.Count, 1).End(xlUp).Row + 1 Target.Offset(0, -6).Resize(1, 5).Copy .Range("A" & per) .Range("A" & per).Resize(1, 5).FormatConditions.Delete With .Range("F" & per) .Value = Date: .Borders.LineStyle = xlContinuous End With End With Target.Offset(0, -6).Resize(1, 7).Delete xlUp End If End Sub
Только я закомментил все остальные процедуры в модуле, ибо мешало. [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim dat&, per&, r As Range, a, i&, n&, j&, c As Range dat = Cells(Rows.Count, 4).End(xlUp).Row If Target.Count > 1 Then Exit Sub If Not Intersect(Target, Range("I4:I" & dat)) Is Nothing Then With ThisWorkbook.Sheets("сводная") per = .Cells(Rows.Count, 1).End(xlUp).Row + 1 Target.Offset(0, -6).Resize(1, 5).Copy .Range("A" & per) .Range("A" & per).Resize(1, 5).FormatConditions.Delete With .Range("F" & per) .Value = Date: .Borders.LineStyle = xlContinuous End With End With Target.Offset(0, -6).Resize(1, 7).ClearContents Set c = Target Do Set c = c.Offset(-1) Loop While c.Interior.ColorIndex <> 6 Set r = Cells(c.Row, 3).Offset(1).Resize(8, 7) a = r.Value: n = 0 For i = 1 To UBound(a) If a(i, 2) <> "" Then n = n + 1 For j = 1 To UBound(a, 2) a(n, j) = a(i, j) Next End If Next r.ClearContents: r.Range("a1").Resize(n, UBound(a, 2)) = a End If End Sub
[/vba]
Только я закомментил все остальные процедуры в модуле, ибо мешало. [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim dat&, per&, r As Range, a, i&, n&, j&, c As Range dat = Cells(Rows.Count, 4).End(xlUp).Row If Target.Count > 1 Then Exit Sub If Not Intersect(Target, Range("I4:I" & dat)) Is Nothing Then With ThisWorkbook.Sheets("сводная") per = .Cells(Rows.Count, 1).End(xlUp).Row + 1 Target.Offset(0, -6).Resize(1, 5).Copy .Range("A" & per) .Range("A" & per).Resize(1, 5).FormatConditions.Delete With .Range("F" & per) .Value = Date: .Borders.LineStyle = xlContinuous End With End With Target.Offset(0, -6).Resize(1, 7).ClearContents Set c = Target Do Set c = c.Offset(-1) Loop While c.Interior.ColorIndex <> 6 Set r = Cells(c.Row, 3).Offset(1).Resize(8, 7) a = r.Value: n = 0 For i = 1 To UBound(a) If a(i, 2) <> "" Then n = n + 1 For j = 1 To UBound(a, 2) a(n, j) = a(i, j) Next End If Next r.ClearContents: r.Range("a1").Resize(n, UBound(a, 2)) = a End If End Sub
Если удалить из столбца С дубликаты, скрытые белым шрифтом, то можно так [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim dat& Dim ar1, ar2, eR& dat = Columns("E").Find("Нач.мех.цеха", , , xlPart).Row - 2 If Not Intersect(Target, Range("I4:I" & dat)) Is Nothing Then If Target = 1 Then If Len(Cells(Target.Row, 3)) Then Exit Sub eR = Cells(Target.Row, 3).End(xlDown).Row - 1 If eR > dat Then eR = dat ar1 = Cells(Target.Row, 3).Resize(, 6).Value ar1(1, 1) = Cells(Target.Row, 3).End(xlUp).Value Sheets("сводная").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 6).Value = ar1 If eR - Target.Row Then ar2 = Cells(Target.Row + 1, 4).Resize(eR - Target.Row, 5).Value Cells(Target.Row, 4).Resize(eR - Target.Row, 5).Value = ar2 Else Cells(Target.Row, 4).Resize(, 5).ClearContents End If Cells(Target.Row, "I").ClearContents End If End If End Sub
[/vba] А дабы не париться с форматированием на листе сводная, сделать там умную таблицу.
Если удалить из столбца С дубликаты, скрытые белым шрифтом, то можно так [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) Dim dat& Dim ar1, ar2, eR& dat = Columns("E").Find("Нач.мех.цеха", , , xlPart).Row - 2 If Not Intersect(Target, Range("I4:I" & dat)) Is Nothing Then If Target = 1 Then If Len(Cells(Target.Row, 3)) Then Exit Sub eR = Cells(Target.Row, 3).End(xlDown).Row - 1 If eR > dat Then eR = dat ar1 = Cells(Target.Row, 3).Resize(, 6).Value ar1(1, 1) = Cells(Target.Row, 3).End(xlUp).Value Sheets("сводная").Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 6).Value = ar1 If eR - Target.Row Then ar2 = Cells(Target.Row + 1, 4).Resize(eR - Target.Row, 5).Value Cells(Target.Row, 4).Resize(eR - Target.Row, 5).Value = ar2 Else Cells(Target.Row, 4).Resize(, 5).ClearContents End If Cells(Target.Row, "I").ClearContents End If End If End Sub
[/vba] А дабы не париться с форматированием на листе сводная, сделать там умную таблицу.RAN
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
. На листе ФРЗ.ОЦ при установке любого значения в диапазоне I4:I74 строчка перемещается на Лист сводная. Это реализовано. А вот как перенести оставшиеся строчки вверх на освободившееся место? Причем перенос делается только в пределах 8 строчек, ограниченных желтыми строчками.
