Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Горизонтальная сортировка столбцов
 
#1
15.10.2021 14:21:35
Добрый день!
Подскажите, интересует реализация горизонтальной сортировки столбцов по содержимому.
Сейчас использую метод через макрос:
Код
Dim col&
        For col = 91 To 1 Step -1
      If col <> 1 And col <> 2 And col <> 5 And col <> 6 And col <> 7 And col <> 26 And col <> 34 And col <> 35 And col <> 47 And col <> 48 And col <> 52 And col <> 65 And col <> 66 And col <> 67 And col <> 69 And col <> 72 And col <> 78 And col <> 79 And col <> 80 And col <> 81 Then Columns(col).Delete
   Next col
Он работает при статичный столбцах, но в последнее время начали приходить данные, где нумерация столбцов меняется (увеличивает или уменьшается).
Поэтому задумался по сортировке через содержимое. Как такое можно реализовать?
 
 
 
#2
15.10.2021 14:46:57
Код
Sub test()
    Hsort ActiveSheet
End Sub

Sub Hsort(sh As Worksheet)
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual

    Dim arr As Variant
    Dim x As Long
        
    With sh
        x = .Cells(1, .Columns.Count).End(xlToLeft).Column
        arr = .Range(.Cells(1, 1), .Cells(2, x))
        
        Dim brr As Variant
        ReDim brr(1 To UBound(arr, 2), 1 To 2)
        For x = 1 To UBound(brr, 1)
            brr(x, 1) = x
            brr(x, 2) = arr(1, x)
        Next
        Erase arr
        
        Dim wb As Workbook
        Set wb = Workbooks.Add(1)
        With wb.Sheets(1)
            Dim r As Range
            Set r = .Cells(1, 1).Resize(UBound(brr, 1), UBound(brr, 2))
            r = brr
            With .Sort
                .SortFields.Clear
                .SortFields.Add Key:=r.Columns(2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                .SetRange r
                .Header = xlGuess
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            brr = r
        End With
        wb.Close False
        
        .Columns("A:A").Resize(, x).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
        Dim y As Long
        For y = 1 To UBound(brr, 1)
            .Columns(brr(y, 1) + x).Cut Destination:=Columns(y)
        Next
    End With
    
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = Application_Calculation
End Sub
 
 
 
Страницы: 1
Наверх