Код сортировки необходимо усовершенствовать для Excel

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

Мир MS Excel » Вопросы и решения » Вопросы по VBA » Код сортировки необходимо усовершенствовать для Excel (Макросы/Sub)

next777

Дата: Четверг, 31.03.2016, 04:15 | Сообщение № 1

Группа: Пользователи

Ранг: Новичок

Сообщений: 20

Репутация: 0 ±

Замечаний: 20% ±

Excel 2013

[vba]

Код

Sub Сортировка()
    Columns("F:F").Select
    ActiveWorkbook.Worksheets("СУ10").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("СУ10").Sort.SortFields.Add Key:=Range("F2:F5000"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Файлик").Sort
        .SetRange Range("F1:F5000")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

[/vba]

ка этот код сделать чтоб он работал на любом листе
и второе выбрать столбец, а потом сортировать
жду ваших решений

Сортировать нужно 100 листов excel каждый столбец в листе

web-программист

Ответить

dima_dan2012

Дата: Четверг, 31.03.2016, 08:44 | Сообщение № 2

Группа: Пользователи

Ранг: Новичок

Сообщений: 38

Репутация: 8 ±

Замечаний: 0% ±

Excel 2003,2007

Здравствуйте ! Только критерии сортировки надо глянуть.
[vba]

Код

Sub qwe()
For Item = 1 To ActiveWorkbook.Worksheets.Count
With ActiveWorkbook.Worksheets(Item)
        .Activate
        .Columns("F:F").Select

Selection.Sort Key1:=Range("F2:F5000"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

End With
Next Item
End Sub

[/vba]

WM :Z116994103939

Ответить

next777

Дата: Четверг, 31.03.2016, 22:36 | Сообщение № 3

Группа: Пользователи

Ранг: Новичок

Сообщений: 20

Репутация: 0 ±

Замечаний: 20% ±

Excel 2013

Цитата dima_dan2012, 31.03.2016 в 08:44, в сообщении № 2

Здравствуйте ! Только критерии сортировки надо глянуть.

можно обьединить все обрабатываемые столбцы, т.е. нужно несколько разных столбцов с цветными вверху, чтобы эти цветные дальше обрабатывать

Файл во вложении с пояснениями

К сообщению приложен файл: 4388127.xls (77.0 Kb)

web-программист

Сообщение отредактировал next777 - Четверг, 31.03.2016, 22:37

Ответить

dima_dan2012

Дата: Пятница, 01.04.2016, 08:43 | Сообщение № 4

Группа: Пользователи

Ранг: Новичок

Сообщений: 38

Репутация: 8 ±

Замечаний: 0% ±

Excel 2003,2007

Здравствуйте! Что-то типа такого.
[vba]

Код

Sub sort_myMY()
For Item = 1 To ActiveWorkbook.Worksheets.Count

    With ActiveWorkbook.Worksheets(Item)
    For SEL = 2 To 13
        .Activate
        arr_ITEM = Cells(Rows.Count, SEL).End(xlUp).Row
        .Columns(SEL).Select
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range(Cells(2, SEL), Cells(arr_ITEM, SEL)), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
         With ActiveWorkbook.Worksheets(Item).Sort
        .SetRange Range(Cells(2, SEL), Cells(arr_ITEM, SEL))
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
         End With
        Worksheets(Item).Range(Cells(2, SEL), Cells(arr_ITEM, SEL)).RemoveDuplicates Columns:=1, Header:=xlNo



         Next SEL
     End With
Next Item
End Sub

[/vba]

К сообщению приложен файл: 4388127_my-my.xlsm (41.9 Kb)

WM :Z116994103939

Сообщение отредактировал dima_dan2012 - Пятница, 01.04.2016, 13:01

Ответить

Wasilich

Дата: Пятница, 01.04.2016, 11:50 | Сообщение № 5

Группа: Друзья

Ранг: Старожил

Сообщений: 1232

Репутация: 326 ±

Замечаний: 0% ±

2003

Цитата

можно кнопку Duplicate доработать, если не окрасил написать - Дубликатов нет
кнопка удаляет окончательно из столбца повторы но, почему то это делает очень долго, когда выбираешь весь столбец

Малость подправил.

К сообщению приложен файл: next777.xls (87.5 Kb)

Ответить

next777

Дата: Пятница, 01.04.2016, 13:34 | Сообщение № 6

Группа: Пользователи

Ранг: Новичок

Сообщений: 20

Репутация: 0 ±

Замечаний: 20% ±

Excel 2013

Цитата Wasilich, 01.04.2016 в 11:50, в сообщении № 5

Малость подправил.
К сообщению приложен файл: next777.xls(88Kb)

Супер, спасибо вам

web-программист

Ответить

next777

Дата: Пятница, 01.04.2016, 14:21 | Сообщение № 7

Группа: Пользователи

Ранг: Новичок

Сообщений: 20

Репутация: 0 ±

Замечаний: 20% ±

Excel 2013

Цитата Wasilich, 01.04.2016 в 11:50, в сообщении № 5

Duplicate доработать

как сделать, чтобы шапку не окрашивало, т.е. не с 1 строки проверяло а с 2 по столбцу и ниже

и кнопочка Remove удаляла только в своих столбцах, не сравнивала соседний столбец, когда выделаешь несколько столбцов удаляет как то странновато, так его логику удаления не смог понять,) по одному столбцу великолепно удаляет, а вот несколько непонятно удаляет

web-программист

Сообщение отредактировал next777 - Пятница, 01.04.2016, 14:36

Ответить

next777

Дата: Пятница, 01.04.2016, 15:17 | Сообщение № 8

Группа: Пользователи

Ранг: Новичок

Сообщений: 20

Репутация: 0 ±

Замечаний: 20% ±

Excel 2013

Цитата dima_dan2012, 01.04.2016 в 08:43, в сообщении № 4

К сообщению приложен файл: 4388127_my-my.xlsm

спасибо, очень интересно работает
была бы еще инфа в окошке, сколько удалил

web-программист

Сообщение отредактировал next777 - Пятница, 01.04.2016, 15:18

Ответить

next777

Дата: Суббота, 02.04.2016, 00:28 | Сообщение № 9

Группа: Пользователи

Ранг: Новичок

Сообщений: 20

Репутация: 0 ±

Замечаний: 20% ±

Excel 2013

Цитата dima_dan2012, 01.04.2016 в 08:43, в сообщении № 4

Здравствуйте! Что-то типа такого.

Sub sort_myMY()
For Item = 1 To ActiveWorkbook.Worksheets.Count

With ActiveWorkbook.Worksheets(Item)
For SEL = 2 To 13
.Activate
arr_ITEM = Cells(Rows.Count, SEL).End(xlUp).Row
.Columns(SEL).Select
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range(Cells(2, SEL), Cells(arr_ITEM, SEL)), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(Item).Sort
.SetRange Range(Cells(2, SEL), Cells(arr_ITEM, SEL))
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Worksheets(Item).Range(Cells(2, SEL), Cells(arr_ITEM, SEL)).RemoveDuplicates Columns:=1, Header:=xlNo

Next SEL
End With

а можно без сортировки, только на удаление дубликатов акцентировать? т.е убрать из кода сортировку, самому не получается изменить глючит когда окно всталяю сколько удалило

web-программист

Сообщение отредактировал next777 - Суббота, 02.04.2016, 00:30

Ответить

dima_dan2012

Дата: Суббота, 02.04.2016, 21:33 | Сообщение № 10

Группа: Пользователи

Ранг: Новичок

Сообщений: 38

Репутация: 8 ±

Замечаний: 0% ±

Excel 2003,2007

Здравствуйте! Тут совсем просто;)
[vba]

Код

Sub sort_myMY()
For Item = 1 To ActiveWorkbook.Worksheets.Count
    With ActiveWorkbook.Worksheets(Item)
    For SEL = 1 To 13
        .Activate
        arr_ITEM = Cells(Rows.Count, SEL).End(xlUp).Row
        Worksheets(Item).Range(Cells(2, SEL), Cells(arr_ITEM, SEL)).RemoveDuplicates Columns:=1, Header:=xlNo
         Next SEL
     End With
Next Item
End Sub

[/vba]
Добавил вывод количества удаленных дублкатов по всем страницам
[vba]

Код

Dim c As Integer
Sub sort_myMY()
c = 0
For Item = 1 To ActiveWorkbook.Worksheets.Count

    With ActiveWorkbook.Worksheets(Item)
    For SEL = 1 To 13

        .Activate
        arr_ITEm_start = Cells(Rows.Count, SEL).End(xlUp).Row

        Worksheets(Item).Range(Cells(2, SEL), Cells(arr_ITEm_start, SEL)).RemoveDuplicates Columns:=1, Header:=xlNo
        arr_item_end = Cells(Rows.Count, SEL).End(xlUp).Row

         c = c + arr_ITEm_start - arr_item_end
         Next SEL
     End With
Next Item
MsgBox ("Кол-во удаленных дубликатов " & c)
End Sub

[/vba]