Nic70y, По идеи необходимо захватить весь диапазон с данными, через макрорекордер это должно быть так, как показано в следующем примере.
Но захват в моем примере происходит путем фиксированного диапазона "$A$1:$D$10" прописанного в коде Макроса2. Вопрос – как произвести захват данных не ссылаясь на фиксированный диапазон? Ну типа захват в области конечной заполненной строки и конечного столбца (заголовка).
Nic70y, По идеи необходимо захватить весь диапазон с данными, через макрорекордер это должно быть так, как показано в следующем примере.
Но захват в моем примере происходит путем фиксированного диапазона "$A$1:$D$10" прописанного в коде Макроса2. Вопрос – как произвести захват данных не ссылаясь на фиксированный диапазон? Ну типа захват в области конечной заполненной строки и конечного столбца (заголовка).Сергей13
ну такое в голову пришло, мож криво, но работает [vba]
Код
Sub Макрос2() u_1 = Cells(1, Columns.Count).End(xlToLeft).Column u_3 = Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To u_1 u_2 = Cells(Rows.Count, i).End(xlUp).Row If u_2 > Cells(Rows.Count, i - 1).End(xlUp).Row Then u_3 = u_2 Next ActiveSheet.ListObjects("Таблица1").Resize Range(Cells(1, 1), Cells(u_3 + 1, u_1)) End Sub
[/vba]
ну такое в голову пришло, мож криво, но работает [vba]
Код
Sub Макрос2() u_1 = Cells(1, Columns.Count).End(xlToLeft).Column u_3 = Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To u_1 u_2 = Cells(Rows.Count, i).End(xlUp).Row If u_2 > Cells(Rows.Count, i - 1).End(xlUp).Row Then u_3 = u_2 Next ActiveSheet.ListObjects("Таблица1").Resize Range(Cells(1, 1), Cells(u_3 + 1, u_1)) End Sub
Nic70y, Смысл всего этого, это независимая сортировка столбцов. Для этого нужно после вводы данных под любым столбцом, динамической таблицы, произвести последовательную сортировку столбцов, отсюда следует что перед сортировкой необходимо временно убрать таблицу, а после сортировки захватить все данные. Все это в одном коде. Ваш код как бы рабочий, но захват данных, в зависимости от того где были введены данные, происходит не корректно, то есть не полный захват данных. Для полного понимания создал файл из представленных кодов (Вашего и krosav4ig и кода сортировки). Для теста введите данные в ячейку 9I и выполните код кнопкой, захват будет не полный.
Nic70y, Смысл всего этого, это независимая сортировка столбцов. Для этого нужно после вводы данных под любым столбцом, динамической таблицы, произвести последовательную сортировку столбцов, отсюда следует что перед сортировкой необходимо временно убрать таблицу, а после сортировки захватить все данные. Все это в одном коде. Ваш код как бы рабочий, но захват данных, в зависимости от того где были введены данные, происходит не корректно, то есть не полный захват данных. Для полного понимания создал файл из представленных кодов (Вашего и krosav4ig и кода сортировки). Для теста введите данные в ячейку 9I и выполните код кнопкой, захват будет не полный.Сергей13
krosav4ig, Для работы Вашего кода необходимо минимум две заполненные строки, иначе выдает ошибку, в последствии код работает, но независимо от количества заполненных строк не захватывает две последние строки с данными.
krosav4ig, Для работы Вашего кода необходимо минимум две заполненные строки, иначе выдает ошибку, в последствии код работает, но независимо от количества заполненных строк не захватывает две последние строки с данными.Сергей13
Sub sortirovka() 'Раскрытие таблицы Dim b As Boolean, r As Range, col as range With [Таблица1].ListObject Set r = .Range.CurrentRegion For Each col In r.Columns If col.Column = r.Column Then .Resize col.Next.Resize(2) ElseIf Not b Then b = True .Resize r.Resize(2, 2) .Resize r.Resize(2, 1) End If With Intersect(.Parent.UsedRange, col.EntireColumn) .sort .Cells(1), xlAscending, Header:=1 End With Next .Resize r.Resize(r.Rows.Count - IsEmpty(r.Cells(2, 1))) End With End Sub
[/vba]
[vba]
Код
Sub sortirovka() 'Раскрытие таблицы Dim b As Boolean, r As Range, col as range With [Таблица1].ListObject Set r = .Range.CurrentRegion For Each col In r.Columns If col.Column = r.Column Then .Resize col.Next.Resize(2) ElseIf Not b Then b = True .Resize r.Resize(2, 2) .Resize r.Resize(2, 1) End If With Intersect(.Parent.UsedRange, col.EntireColumn) .sort .Cells(1), xlAscending, Header:=1 End With Next .Resize r.Resize(r.Rows.Count - IsEmpty(r.Cells(2, 1))) End With End Sub
krosav4ig, Да… Это кардинально меняет ранее задуманное. Но у меня во всех рабочих листах Option Explicit который ругается на col, в строке For Each col In r.Columns, Это можно исправить? А также есть такой нюанс, при выполнении кода захват идет под конечное значение строки, повторный ввод данных и выполнение кода добавляет пустую строку, то есть идет некое чередование. Это так задумано?
krosav4ig, Да… Это кардинально меняет ранее задуманное. Но у меня во всех рабочих листах Option Explicit который ругается на col, в строке For Each col In r.Columns, Это можно исправить? А также есть такой нюанс, при выполнении кода захват идет под конечное значение строки, повторный ввод данных и выполнение кода добавляет пустую строку, то есть идет некое чередование. Это так задумано?Сергей13
Сообщение отредактировал Сергей13 - Пятница, 01.03.2019, 02:32
Sub sortirovka() 'Раскрытие таблицы Dim r As Range, i&, j&, v As Variant, arr() As Variant With [Таблица1].ListObject With .Range.CurrentRegion If .Rows.Count < 2 Then Exit Sub ReDim Preserve arr(1 To .Rows.Count - 1, 1 To .Columns.Count) For j = 1 To .Columns.Count For Each r In .Columns(j) i = 1 For Each v In BubbleSort(Intersect(r, r.Offset(1)).Value) arr(i, j) = v i = i + 1 Next v, r, j Intersect(.Offset(1), .Cells).ClearContents .Cells(2, 1).Resize(i - 1, j - 1) = arr End With .Resize .Range.CurrentRegion End With End Sub Function BubbleSort(v As Variant) As Variant Dim i&, j&, b As Boolean If Not IsArray(v) Then BubbleSort = Array(v): Exit Function b = UBound(v) >= UBound(v, 2) For i = 1 To UBound(v, IIf(b, 1, 2)) - 1: For j = i To UBound(v, IIf(b, 1, 2)) swap v(IIf(b, i, 1), IIf(b, 1, i)), v(IIf(b, j, 1), IIf(b, 1, j)) Next j, i BubbleSort = v End Function Sub swap(ByRef a As Variant, b As Variant) If a < b Xor (a <> "") And (b <> "") Then: Dim c: c = a: a = b: b = c End Sub
[/vba]
[vba]
Код
Sub sortirovka() 'Раскрытие таблицы Dim r As Range, i&, j&, v As Variant, arr() As Variant With [Таблица1].ListObject With .Range.CurrentRegion If .Rows.Count < 2 Then Exit Sub ReDim Preserve arr(1 To .Rows.Count - 1, 1 To .Columns.Count) For j = 1 To .Columns.Count For Each r In .Columns(j) i = 1 For Each v In BubbleSort(Intersect(r, r.Offset(1)).Value) arr(i, j) = v i = i + 1 Next v, r, j Intersect(.Offset(1), .Cells).ClearContents .Cells(2, 1).Resize(i - 1, j - 1) = arr End With .Resize .Range.CurrentRegion End With End Sub Function BubbleSort(v As Variant) As Variant Dim i&, j&, b As Boolean If Not IsArray(v) Then BubbleSort = Array(v): Exit Function b = UBound(v) >= UBound(v, 2) For i = 1 To UBound(v, IIf(b, 1, 2)) - 1: For j = i To UBound(v, IIf(b, 1, 2)) swap v(IIf(b, i, 1), IIf(b, 1, i)), v(IIf(b, j, 1), IIf(b, 1, j)) Next j, i BubbleSort = v End Function Sub swap(ByRef a As Variant, b As Variant) If a < b Xor (a <> "") And (b <> "") Then: Dim c: c = a: a = b: b = c End Sub
Не тестируется, выдает ошибку на r в строке For Each r In .Columns(j) Путем тыка объявил ее переменной в строке Dim i&, j&, v, r As Variant, arr() As Variant
Теперь при любом раскладе выдает ошибку на переменную v в строке Next v, j, i но по коду v вроде-бы объявлена переменной?
krosav4ig, Здравствуйте.
Не тестируется, выдает ошибку на r в строке For Each r In .Columns(j) Путем тыка объявил ее переменной в строке Dim i&, j&, v, r As Variant, arr() As Variant
Теперь при любом раскладе выдает ошибку на переменную v в строке Next v, j, i но по коду v вроде-бы объявлена переменной?Сергей13
Сообщение отредактировал Сергей13 - Пятница, 01.03.2019, 18:39
krosav4ig, Намного эффективно по отношению к тому что я пытался наворочить. Спасибо! В тестовом варианте вроде все нормально, буду пробовать впихивать в рабочий. Благодарю за помощь!
krosav4ig, Намного эффективно по отношению к тому что я пытался наворочить. Спасибо! В тестовом варианте вроде все нормально, буду пробовать впихивать в рабочий. Благодарю за помощь!Сергей13
krosav4ig, Еще один нюанс всплыл. Если динамическая таблица первоначально пуста, то выдается ошибка. В ходе тестирования понял то, что код функционирует при наличии данных в любых ячейках двух начальных строк. Если это такова изначальная необходимость, то можно ли как-то просто не выполнять код при отсутствии данных в двух строках таблицы?
krosav4ig, Еще один нюанс всплыл. Если динамическая таблица первоначально пуста, то выдается ошибка. В ходе тестирования понял то, что код функционирует при наличии данных в любых ячейках двух начальных строк. Если это такова изначальная необходимость, то можно ли как-то просто не выполнять код при отсутствии данных в двух строках таблицы?Сергей13
Сообщение отредактировал Сергей13 - Пятница, 01.03.2019, 23:55