With Rows(i).Borders(xlEdgeBottom) .LineStyle = xlDash .Weight = xlMedium End With
End If
Next i
'--------------------------------------------------------------------------------------------- 'ГРУППИРОВКА ПО ВТОРОМУ СТОЛБЦУ.
'Т.к. количество строк изменилось, нужно заново провести некоторые действия. myLastRow = Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row
'Берём в VBA-таблицу "tblA" данные из второго столбца. tblA() = Cells(1, ActiveCell.Column + 1).Resize(myLastRow, 1).Value
For i = UBound(tblA, 1) To 2 Step -1
'Если текущая или вышестоящая ячейка пустые. If IsEmpty(tblA(i, 1)) = True Or IsEmpty(tblA(i - 1, 1)) = True Then 'Переходим к следующей ячейке. GoTo metka End If
'Если данные в текущей ячейке и вышестоящей ячейке разные. If tblA(i, 1) <> tblA(i - 1, 1) Then
With Rows(i).Borders(xlEdgeBottom) .LineStyle = xlDash .Weight = xlMedium End With
End If
Next i
'--------------------------------------------------------------------------------------------- 'ГРУППИРОВКА ПО ВТОРОМУ СТОЛБЦУ.
'Т.к. количество строк изменилось, нужно заново провести некоторые действия. myLastRow = Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row
'Берём в VBA-таблицу "tblA" данные из второго столбца. tblA() = Cells(1, ActiveCell.Column + 1).Resize(myLastRow, 1).Value
For i = UBound(tblA, 1) To 2 Step -1
'Если текущая или вышестоящая ячейка пустые. If IsEmpty(tblA(i, 1)) = True Or IsEmpty(tblA(i - 1, 1)) = True Then 'Переходим к следующей ячейке. GoTo metka End If
'Если данные в текущей ячейке и вышестоящей ячейке разные. If tblA(i, 1) <> tblA(i - 1, 1) Then
Работает, но ожидал другую реализацию, за один проход. Недостаток в том, что если добавится еще одна подгруппа по третьему столбцу, макрос придется не немного подправить, а добавить третий блок, в котором кол-во проверок возрастет. Совсем не знаю VBА, но из вашего кода вижу что логические операции поддерживаются. На каком то несуществующем языке полупрограмму-полуалгоритм вижу так: [vba]
Код
go bottom //стать на последнюю строку st_1=A1 // присвоить значение ячейки колонки А1 последней строки st_2=A2 // присвоить значение ячейки колонки А2 последней строки do while not bof() // цикл от последней строки до первой skip -1 // подняться на одну строку вверх if st_1<>a1 // если в текущей строке и в следующей значения разные, // то здесь нужно группы разделить здесь после текущей строки вставляем две строки с разделителем из пунктирной линии skip -1 // skip -1 //возврат на текущую строку, в VBA не надо, так как обрабатывается массив endif if st_1=a1 and st_2<>a2 // перехода через группу нет, а через подгруппу есть здесь нужно добавить одну пустую строку skip -1 //возврат на текущую строку, в VBA не надо, так как обрабатывается массив endif // если оба условия не выполняются, то ничего не делается st_1=A1 // присвоить значение ячейки колонки А1 текущей строки st_2=A2 // // присвоить значение ячейки колонки А2 текущей строки end do
[/vba]
Работает, но ожидал другую реализацию, за один проход. Недостаток в том, что если добавится еще одна подгруппа по третьему столбцу, макрос придется не немного подправить, а добавить третий блок, в котором кол-во проверок возрастет. Совсем не знаю VBА, но из вашего кода вижу что логические операции поддерживаются. На каком то несуществующем языке полупрограмму-полуалгоритм вижу так: [vba]
Код
go bottom //стать на последнюю строку st_1=A1 // присвоить значение ячейки колонки А1 последней строки st_2=A2 // присвоить значение ячейки колонки А2 последней строки do while not bof() // цикл от последней строки до первой skip -1 // подняться на одну строку вверх if st_1<>a1 // если в текущей строке и в следующей значения разные, // то здесь нужно группы разделить здесь после текущей строки вставляем две строки с разделителем из пунктирной линии skip -1 // skip -1 //возврат на текущую строку, в VBA не надо, так как обрабатывается массив endif if st_1=a1 and st_2<>a2 // перехода через группу нет, а через подгруппу есть здесь нужно добавить одну пустую строку skip -1 //возврат на текущую строку, в VBA не надо, так как обрабатывается массив endif // если оба условия не выполняются, то ничего не делается st_1=A1 // присвоить значение ячейки колонки А1 текущей строки st_2=A2 // // присвоить значение ячейки колонки А2 текущей строки end do
With Rows(i).Borders(xlEdgeBottom) .LineStyle = xlDash .Weight = xlMedium End With
'Если данные во втором столбце в текущей строке и строке, 'которая выше, не совпадают. ElseIf tblMy(i, 2) <> tblMy(i - 1, 2) Then Rows(i).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow End If
Next i
Application.ScreenUpdating = True
End Sub
[/vba]
SergeyKorotun, да, вы правы, есть другой способ решения вашей задачи:
[vba]
Код
Sub Procedure_1()
Dim tblMy() As Variant Dim myLastRow As Long Dim i As Long
With Rows(i).Borders(xlEdgeBottom) .LineStyle = xlDash .Weight = xlMedium End With
'Если данные во втором столбце в текущей строке и строке, 'которая выше, не совпадают. ElseIf tblMy(i, 2) <> tblMy(i - 1, 2) Then Rows(i).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow End If
А можно еще после вставки двух пустых строк с пунктирной границей между ними вставлять еще и первую строку, чтобы в каждой группы была своя шапка
А можно еще после вставки двух пустых строк с пунктирной границей между ними вставлять еще и первую строку, чтобы в каждой группы была своя шапкаSergeyKorotun
Dim tblMy() As Variant Dim myLastRow As Long Dim myActiveColumn As Long Dim i As Long
Application.ScreenUpdating = False
'Берём номер столбца, где находится активная ячейка, 'в переменную. Т.к. этот номер столбца 'в коде нужен несколько раз и удобнее указывать 'переменную вместо "ActiveCell.Column", 'т.к. можно что-нибудь забыть сделать, 'если код будет меняться и данные будут браться не те. myActiveColumn = ActiveCell.Column
'Берём в VBA-таблицу "tblMy" данные из двух столбцов. tblMy() = Cells(1, myActiveColumn).Resize(myLastRow, 2).Value
For i = UBound(tblMy, 1) To 2 Step -1
'Если данные в первом столбце в текущей строке и строке, 'которая выше, не совпадают. If tblMy(i, 1) <> tblMy(i - 1, 1) Then
'Вставка двух пустых строк между группами. Rows(i).Resize(2).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow
'Делаем границу между двумя вставленными 'пустыми строками. With Rows(i).Borders(xlEdgeBottom) .LineStyle = xlDash .Weight = xlMedium End With
'Делаем заголовок у нижней группы. Cells(i + 1, myActiveColumn).Value = "Шапка группы"
'Если данные во втором столбце в текущей строке и строке, 'которая выше, не совпадают. ElseIf tblMy(i, 2) <> tblMy(i - 1, 2) Then Rows(i).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow End If
Next i
Application.ScreenUpdating = True
End Sub
[/vba]
[vba]
Код
Sub Procedure_1()
Dim tblMy() As Variant Dim myLastRow As Long Dim myActiveColumn As Long Dim i As Long
Application.ScreenUpdating = False
'Берём номер столбца, где находится активная ячейка, 'в переменную. Т.к. этот номер столбца 'в коде нужен несколько раз и удобнее указывать 'переменную вместо "ActiveCell.Column", 'т.к. можно что-нибудь забыть сделать, 'если код будет меняться и данные будут браться не те. myActiveColumn = ActiveCell.Column
'Берём в VBA-таблицу "tblMy" данные из двух столбцов. tblMy() = Cells(1, myActiveColumn).Resize(myLastRow, 2).Value
For i = UBound(tblMy, 1) To 2 Step -1
'Если данные в первом столбце в текущей строке и строке, 'которая выше, не совпадают. If tblMy(i, 1) <> tblMy(i - 1, 1) Then
'Вставка двух пустых строк между группами. Rows(i).Resize(2).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow
'Делаем границу между двумя вставленными 'пустыми строками. With Rows(i).Borders(xlEdgeBottom) .LineStyle = xlDash .Weight = xlMedium End With
'Делаем заголовок у нижней группы. Cells(i + 1, myActiveColumn).Value = "Шапка группы"
'Если данные во втором столбце в текущей строке и строке, 'которая выше, не совпадают. ElseIf tblMy(i, 2) <> tblMy(i - 1, 2) Then Rows(i).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow End If
Немного не так. Вставляться должно не "шапка группы", а существующая строка из этой же таблицы, в которой подписаны наименования столбцов. В прикрепленном файле на первом листе заготовка, а на втором - что должно получиться после работы макроса. Теперь курсор будет устанавливаться не только в первый столбец, участвующий в группировке, но еще и на строку с шапкой. Но параметр цикла можно оставить и 1, лишнюю первую шапку можно удалить вручную.
Немного не так. Вставляться должно не "шапка группы", а существующая строка из этой же таблицы, в которой подписаны наименования столбцов. В прикрепленном файле на первом листе заготовка, а на втором - что должно получиться после работы макроса. Теперь курсор будет устанавливаться не только в первый столбец, участвующий в группировке, но еще и на строку с шапкой. Но параметр цикла можно оставить и 1, лишнюю первую шапку можно удалить вручную.SergeyKorotun
'Берём в VBA-таблицу "tblMy" данные из двух столбцов. tblMy() = Cells(1, myActiveColumn).Resize(myLastRow, 2).Value
'Двигаемся до третьей строки, т.к. в первой строке 'находится заголовок и вторую строку 'не нужно сравнивать с первой. For i = UBound(tblMy, 1) To 3 Step -1
'Если данные в первом столбце в текущей строке и строке, 'которая выше, не совпадают. If tblMy(i, 1) <> tblMy(i - 1, 1) Then
'Вставка трёх пустых строк между группами. Rows(i).Resize(3).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow
'Делаем границу между двумя вставленными 'пустыми строками. With Rows(i).Borders(xlEdgeBottom) .LineStyle = xlDash .Weight = xlMedium End With
'Делаем заголовок у нижней группы. 'Копируем заголовок из первой строки Excel-листа. 'Копировать нужно, т.к. нужно сохранять форматирование. Cells(1, myActiveColumn).Resize(1, 3).Copy _ Destination:=Cells(i + 2, myActiveColumn)
'Если данные во втором столбце в текущей строке и строке, 'которая выше, не совпадают. ElseIf tblMy(i, 2) <> tblMy(i - 1, 2) Then Rows(i).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow End If
Next i
Application.ScreenUpdating = True
End Sub
[/vba]
[vba]
Код
Sub Procedure_1()
Dim tblMy() As Variant Dim myLastRow As Long Dim myActiveColumn As Long Dim i As Long
Application.ScreenUpdating = False
'Берём номер столбца, где находится активная ячейка, 'в переменную. myActiveColumn = ActiveCell.Column
'Берём в VBA-таблицу "tblMy" данные из двух столбцов. tblMy() = Cells(1, myActiveColumn).Resize(myLastRow, 2).Value
'Двигаемся до третьей строки, т.к. в первой строке 'находится заголовок и вторую строку 'не нужно сравнивать с первой. For i = UBound(tblMy, 1) To 3 Step -1
'Если данные в первом столбце в текущей строке и строке, 'которая выше, не совпадают. If tblMy(i, 1) <> tblMy(i - 1, 1) Then
'Вставка трёх пустых строк между группами. Rows(i).Resize(3).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow
'Делаем границу между двумя вставленными 'пустыми строками. With Rows(i).Borders(xlEdgeBottom) .LineStyle = xlDash .Weight = xlMedium End With
'Делаем заголовок у нижней группы. 'Копируем заголовок из первой строки Excel-листа. 'Копировать нужно, т.к. нужно сохранять форматирование. Cells(1, myActiveColumn).Resize(1, 3).Copy _ Destination:=Cells(i + 2, myActiveColumn)
'Если данные во втором столбце в текущей строке и строке, 'которая выше, не совпадают. ElseIf tblMy(i, 2) <> tblMy(i - 1, 2) Then Rows(i).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromRightOrBelow End If
Добрый день! Необходим аналогичный макрос - добавление пустой строки после изменения значения в столбце и суммирование по всем столбцам в этой пустой строке, подскажите как добиться этого Вашими предложенными макросами?
Добрый день! Необходим аналогичный макрос - добавление пустой строки после изменения значения в столбце и суммирование по всем столбцам в этой пустой строке, подскажите как добиться этого Вашими предложенными макросами?Алекс
мне нужно тоже самое только вместо линии надо вставить последнее значение я знаю что тут просто вместо линии написать оператор с последним значением но не знаю как ...
БОЛЬШОЕ СПАСИБО !!! [moder]Хоть вопрос и похожий, но все-таки немного другой. А посему отсылаю Вас к пункту 5q Правил форума, а тему закрываю.
Люди добрые помогите плиз
мне нужно тоже самое только вместо линии надо вставить последнее значение я знаю что тут просто вместо линии написать оператор с последним значением но не знаю как ...
БОЛЬШОЕ СПАСИБО !!! [moder]Хоть вопрос и похожий, но все-таки немного другой. А посему отсылаю Вас к пункту 5q Правил форума, а тему закрываю.lexkaz
topsa.kz
Сообщение отредактировал _Boroda_ - Пятница, 17.07.2015, 09:18