misharin
Дата: Понедельник, 16.12.2019, 20:59 |
Сообщение № 21
Группа: Пользователи
Ранг: Новичок
Сообщений: 42
Репутация:
0
±
Замечаний:
0% ±
Excel 2007
Макрос который использовался
[vba]
Код
Sub ОЗУ2019ф6() Dim Wb As Workbook For Each Wb In Workbooks MsgBox Wb.Name Next Dim arr(), lr As Long, i As Long Application.ScreenUpdating = False ActiveSheet.Copy After:=ActiveSheet ActiveSheet.AutoFilterMode = False Rows.Hidden = False ActiveSheet.Sort.SortFields.Clear ActiveSheet.Sort.SortFields.Add Key:=Columns("A"), SortOn:=xlSortOnValues, Order:=xlAscending ActiveSheet.Sort.SortFields.Add Key:=Columns("G"), SortOn:=xlSortOnValues, Order:=xlAscending ActiveSheet.Sort.SortFields.Add Key:=Columns("I"), SortOn:=xlSortOnValues, Order:=xlAscending ActiveSheet.Sort.SortFields.Add Key:=Columns("C"), SortOn:=xlSortOnValues, Order:=xlAscending With ActiveSheet.Sort .SetRange Columns("A:I").Rows("3:" & Rows.Count) .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .Apply End With lr = Cells(Rows.Count, "A").End(xlUp).Row arr() = Range("A1:I" & lr).Value For i = UBound(arr) To 9 Step -1 If arr(i, 1) = arr(i - 1, 1) And arr(i, 7) = arr(i - 1, 7) And arr(i, 9) = arr(i - 1, 9) And arr(i, 3) = arr(i - 1, 3) Then arr(i - 1, 4) = arr(i - 1, 4) & "," & arr(i, 4) arr(i - 1, 5) = arr(i - 1, 5) + arr(i, 5) arr(i, 1) = Empty End If Next i Range("A1:I" & lr).Value = arr() On Error Resume Next Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete On Error GoTo 0 Application.ScreenUpdating = True End Sub
[/vba]
Макрос который использовался
[vba]
Код
Sub ОЗУ2019ф6() Dim Wb As Workbook For Each Wb In Workbooks MsgBox Wb.Name Next Dim arr(), lr As Long, i As Long Application.ScreenUpdating = False ActiveSheet.Copy After:=ActiveSheet ActiveSheet.AutoFilterMode = False Rows.Hidden = False ActiveSheet.Sort.SortFields.Clear ActiveSheet.Sort.SortFields.Add Key:=Columns("A"), SortOn:=xlSortOnValues, Order:=xlAscending ActiveSheet.Sort.SortFields.Add Key:=Columns("G"), SortOn:=xlSortOnValues, Order:=xlAscending ActiveSheet.Sort.SortFields.Add Key:=Columns("I"), SortOn:=xlSortOnValues, Order:=xlAscending ActiveSheet.Sort.SortFields.Add Key:=Columns("C"), SortOn:=xlSortOnValues, Order:=xlAscending With ActiveSheet.Sort .SetRange Columns("A:I").Rows("3:" & Rows.Count) .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .Apply End With lr = Cells(Rows.Count, "A").End(xlUp).Row arr() = Range("A1:I" & lr).Value For i = UBound(arr) To 9 Step -1 If arr(i, 1) = arr(i - 1, 1) And arr(i, 7) = arr(i - 1, 7) And arr(i, 9) = arr(i - 1, 9) And arr(i, 3) = arr(i - 1, 3) Then arr(i - 1, 4) = arr(i - 1, 4) & "," & arr(i, 4) arr(i - 1, 5) = arr(i - 1, 5) + arr(i, 5) arr(i, 1) = Empty End If Next i Range("A1:I" & lr).Value = arr() On Error Resume Next Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete On Error GoTo 0 Application.ScreenUpdating = True End Sub
[/vba]
misharin
Сообщение отредактировал misharin - Вторник, 17.12.2019, 09:58
Ответить
Сообщение Макрос который использовался
[vba]
Код
Sub ОЗУ2019ф6() Dim Wb As Workbook For Each Wb In Workbooks MsgBox Wb.Name Next Dim arr(), lr As Long, i As Long Application.ScreenUpdating = False ActiveSheet.Copy After:=ActiveSheet ActiveSheet.AutoFilterMode = False Rows.Hidden = False ActiveSheet.Sort.SortFields.Clear ActiveSheet.Sort.SortFields.Add Key:=Columns("A"), SortOn:=xlSortOnValues, Order:=xlAscending ActiveSheet.Sort.SortFields.Add Key:=Columns("G"), SortOn:=xlSortOnValues, Order:=xlAscending ActiveSheet.Sort.SortFields.Add Key:=Columns("I"), SortOn:=xlSortOnValues, Order:=xlAscending ActiveSheet.Sort.SortFields.Add Key:=Columns("C"), SortOn:=xlSortOnValues, Order:=xlAscending With ActiveSheet.Sort .SetRange Columns("A:I").Rows("3:" & Rows.Count) .Header = xlNo .MatchCase = False .Orientation = xlTopToBottom .Apply End With lr = Cells(Rows.Count, "A").End(xlUp).Row arr() = Range("A1:I" & lr).Value For i = UBound(arr) To 9 Step -1 If arr(i, 1) = arr(i - 1, 1) And arr(i, 7) = arr(i - 1, 7) And arr(i, 9) = arr(i - 1, 9) And arr(i, 3) = arr(i - 1, 3) Then arr(i - 1, 4) = arr(i - 1, 4) & "," & arr(i, 4) arr(i - 1, 5) = arr(i - 1, 5) + arr(i, 5) arr(i, 1) = Empty End If Next i Range("A1:I" & lr).Value = arr() On Error Resume Next Columns("A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete On Error GoTo 0 Application.ScreenUpdating = True End Sub
[/vba]
Автор - misharin Дата добавления - 16.12.2019 в 20:59
китин
Дата: Вторник, 17.12.2019, 08:24 |
Сообщение № 22
Группа: Модераторы
Ранг: Экселист
Сообщений: 7028
Репутация:
1077
±
Замечаний:
0% ±
Excel 2007;2010;2016
misharin , - Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку # , пояснялка здесь )
misharin , - Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку # , пояснялка здесь )китин
Не судите очень строго:я пытаюсь научиться ЯД 41001877306852
Ответить
Сообщение misharin , - Оформите код тегами (в режиме правки поста выделите код и нажмите кнопку # , пояснялка здесь )Автор - китин Дата добавления - 17.12.2019 в 08:24
misharin
Дата: Вторник, 03.03.2020, 16:28 |
Сообщение № 23
Группа: Пользователи
Ранг: Новичок
Сообщений: 42
Репутация:
0
±
Замечаний:
0% ±
Excel 2007
Большая просьба! Помогите пожалуйста создать на основе выше приведенного макроса возможность созданием перечня (перечисление номеров выделов) с дефисом в случае последовательности номеров. Т.е. представленный макрос делает перечень в виде 1,2,3,4,7,8,9. А нужно доработать макрос, чтобы делал 1-4, 7-9.
Большая просьба! Помогите пожалуйста создать на основе выше приведенного макроса возможность созданием перечня (перечисление номеров выделов) с дефисом в случае последовательности номеров. Т.е. представленный макрос делает перечень в виде 1,2,3,4,7,8,9. А нужно доработать макрос, чтобы делал 1-4, 7-9. misharin
Сообщение отредактировал misharin - Вторник, 03.03.2020, 16:33
Ответить
Сообщение Большая просьба! Помогите пожалуйста создать на основе выше приведенного макроса возможность созданием перечня (перечисление номеров выделов) с дефисом в случае последовательности номеров. Т.е. представленный макрос делает перечень в виде 1,2,3,4,7,8,9. А нужно доработать макрос, чтобы делал 1-4, 7-9. Автор - misharin Дата добавления - 03.03.2020 в 16:28
misharin
Дата: Воскресенье, 18.09.2022, 11:44 |
Сообщение № 24
Группа: Пользователи
Ранг: Новичок
Сообщений: 42
Репутация:
0
±
Замечаний:
0% ±
Excel 2007
Просьба помочь с макросом для обобщения данных с ячеек по условия: Есть таблица со столбцами A-G Отсортировать по А. С и D Сгруппироать последовательно по А, С, D при значения равно 0 в столбце G, и со значением больше 0 в столбце G. При этом значения из столбца D собираются в одну ячейку перечислением через запятую. а по столбцу E собираются в одну ячейуц суммированием. Пример исходной таблицы и конечного результата прилагаю.
Просьба помочь с макросом для обобщения данных с ячеек по условия: Есть таблица со столбцами A-G Отсортировать по А. С и D Сгруппироать последовательно по А, С, D при значения равно 0 в столбце G, и со значением больше 0 в столбце G. При этом значения из столбца D собираются в одну ячейку перечислением через запятую. а по столбцу E собираются в одну ячейуц суммированием. Пример исходной таблицы и конечного результата прилагаю. misharin
Ответить
Сообщение Просьба помочь с макросом для обобщения данных с ячеек по условия: Есть таблица со столбцами A-G Отсортировать по А. С и D Сгруппироать последовательно по А, С, D при значения равно 0 в столбце G, и со значением больше 0 в столбце G. При этом значения из столбца D собираются в одну ячейку перечислением через запятую. а по столбцу E собираются в одну ячейуц суммированием. Пример исходной таблицы и конечного результата прилагаю. Автор - misharin Дата добавления - 18.09.2022 в 11:44