mail mail
Нужен макрос для Excel?
Сделайте заказ прямо сейчас!
Ищете готовое решение?
Выбирайте и покупайте!
У вас есть интернет-магазин?
Настроим парсер под любой сайт!

Перестановка столбцов в двумерном массиве (функция на VBA)

Функция ArraySwapColumns позволяет переставить в нужном порядке столбцы двумерного массива.
Кроме того, попутно можно изменить вторую размерность массива (чтобы убрать лишние столбцы, или добавить недостающие)

См. пример использования в прикреплённом файле.

Function ArraySwapColumns(ByVal arr As Variant, ByVal NewColumnsOrder$, _
                          Optional ByVal OptionBase As Integer = 1) As Variant
    ' функция принимает в качестве параметра двумерный массив arr
    ' (для перестановки столбцов)
    ' и текстовую строку NewColumnsOrder с новым порядком столбцов
    ' в формате ",,5,6,8,,9-15,18,2,9-11,,1,4,,21,"
    On Error Resume Next
    ColumnsArray = ParseColumnsString(NewColumnsOrder$)
    NewUBound% = UBound(ColumnsArray) + 1
 
    ReDim tmpArr(LBound(arr, 1) To UBound(arr, 1), LBound(arr, 2) To NewUBound%)
 
    For j = LBound(ColumnsArray) To UBound(ColumnsArray)
        OldColumn% = ColumnsArray(j) + 1 - OptionBase
        NewColumn% = j + LBound(arr, 2)
        If OldColumn% >= 0 Then
            For i = LBound(arr, 1) To UBound(arr, 1)    ' перенос столбца
                tmpArr(i, NewColumn%) = arr(i, OldColumn%)
            Next i
        End If
    Next j
    ArraySwapColumns = tmpArr
End Function
 
 
Function ParseColumnsString(ByVal txt$) As Variant
    ' Принимает в качестве параметра строку типа ",,5,6,8,,9-15,18,2,11-9,,1,4,,21,"
    ' Возвращает одномерный (горизонтальный) массив в формате
    ' array(-1,-1,5,6,8,-1,9,10,11,12,13,14,15,18,2,11,10,9,-1,1,4,-1,21,-1)
    ' (пустые значения заменяются на -1; диапазоны типа 9-15 и 17-13 раскрываются)
    arr = Split(Replace(txt$, " ", ""), ","): Dim n As Long: ReDim tmpArr(0 To 0)
    For i = LBound(arr) To UBound(arr)
        Select Case True
            Case arr(i) = "", Val(arr(i)) < 0
                tmpArr(UBound(tmpArr)) = -1: ReDim Preserve tmpArr(0 To UBound(tmpArr) + 1)
            Case IsNumeric(arr(i))
                tmpArr(UBound(tmpArr)) = arr(i): ReDim Preserve tmpArr(0 To UBound(tmpArr) + 1)
            Case arr(i) Like "*#-#*"
                spl = Split(arr(i), "-")
                If UBound(spl) = 1 Then
                    If IsNumeric(spl(0)) And IsNumeric(spl(1)) Then
                        For j = Val(spl(0)) To Val(spl(1)) Step IIf(Val(spl(0)) > Val(spl(1)), -1, 1)
                            tmpArr(UBound(tmpArr)) = j: ReDim Preserve tmpArr(0 To UBound(tmpArr) + 1)
                        Next j
                    End If
                End If
        End Select
    Next i
    On Error Resume Next: ReDim Preserve tmpArr(0 To UBound(tmpArr) - 1)
    ParseColumnsString = tmpArr
End Function

--------------------- добавлено позже ----------------------
То же самое, но в виде одной функции:

Function SWAP(ByVal arr As Variant, ByVal NewColumnsOrder$) As Variant
    ' Функция принимает в качестве параметра двумерный массив arr (для перестановки столбцов)
    ' и текстовую строку NewColumnsOrder с новым порядком столбцов в формате ",,5,6,8,,9-15,18,2,9-11,,1,4,,21,"
    ' Возвращает массив, в котором столбцы переставлены в нужном порядке
    On Error Resume Next
    cols = Split(Replace(NewColumnsOrder$, " ", ""), ","): Dim n As Long: ReDim colArr(0 To 0)
    For i = LBound(cols) To UBound(cols)
        Select Case True
            Case cols(i) = "", Val(cols(i)) < 0
                colArr(UBound(colArr)) = -1: ReDim Preserve colArr(0 To UBound(colArr) + 1)
            Case IsNumeric(cols(i))
                colArr(UBound(colArr)) = cols(i): ReDim Preserve colArr(0 To UBound(colArr) + 1)
            Case cols(i) Like "*#-#*"
                spl = Split(cols(i), "-")
                If UBound(spl) = 1 Then
                    If IsNumeric(spl(0)) And IsNumeric(spl(1)) Then
                        For j = Val(spl(0)) To Val(spl(1)) Step IIf(Val(spl(0)) > Val(spl(1)), -1, 1)
                            colArr(UBound(colArr)) = j: ReDim Preserve colArr(0 To UBound(colArr) + 1)
                        Next j
                    End If
                End If
        End Select
    Next i
    ReDim Preserve colArr(0 To UBound(colArr) - 1)
    ColumnsArray = colArr
 
    ReDim tmpArr(LBound(arr, 1) To UBound(arr, 1), LBound(arr, 2) To UBound(ColumnsArray) + 1)
    For j = LBound(ColumnsArray) To UBound(ColumnsArray)
        If Val(ColumnsArray(j)) >= 0 Then
            For i = LBound(arr, 1) To UBound(arr, 1): tmpArr(i, j + LBound(arr, 2)) = arr(i, Val(ColumnsArray(j))): Next i
        End If
    Next j
    SWAP = tmpArr
End Function

Пример использования (для перeстановки столбцов на листе Excel)

Range("k1:o30").Value = SWAP(Range("a1:h30").Value, "2,5,1,,8")

ВложениеРазмерЗагрузкиПоследняя загрузка
SwapColumns.xls53.5 КБ1016 недель 6 дней назад

Комментарии

Настройки просмотра комментариев

Выберите нужный метод показа комментариев и нажмите "Сохранить установки".

Никита, для этих целей я использую функцию объединения двумерных массивов:
http://excelvba.ru/code/CombineArrays

Добрый день!

Каким образом добавить полученный массив в конец к уже существующему?

Спасибо, теперь разобрался.

Обратите внимание на последнюю строку в макросе - примере использования:

Sub ПримерИспользования_ArraySwapColumns()
    ' считываем массив с листа
    arr = [a1:e20].Value
    ' считываем новый порядок столбцов
    Порядок = [NewOrder]
    ' переставляем столбцы, получаем новый массив newarr
    newarr = ArraySwapColumns(arr, Порядок)
 
    ' заносим результат на лист (начиная вставку с ячейки G1)
    Range("g1").Resize(UBound(newarr, 1), UBound(newarr, 2)).Value = newarr
End Sub

Range("g1") - это ячейка, начиная с которой, будет вставлен новый массив на лист

А каким образом изменить диапазон для размещения переставленной матрицы ?

Отправить комментарий

Содержание этого поля является приватным и не предназначено к показу.
CAPTCHA
Подтвердите, пожалуйста, что вы - человек:
      _   ____    _  _     _       _____        
| | | _ \ | || | | |__ |_ _| _ __
_ | | | |_) | | || |_ | '_ \ | | | '__|
| |_| | | __/ |__ _| | | | | | | | |
\___/ |_| |_| |_| |_| |_| |_|
Введите код, изображенный в стиле ASCII-арт.

Не получается применить макрос? Не удаётся изменить код под свои нужды?

Оформите заказ у нас на сайте, не забыв прикрепить примеры файлов, и описать, что и как должно работать.