Vba excel перевернуть массив

Как известно, встроенная в Excel функция листа Transpose имеет ограничения, вследствии чего её не удаётся применять для транспонирования произвольных массивов.

Вот список ограничений  встроенной функции Transpose:

  • Массив не может содержать элементов, длина которых превышает 255 знаков.
  • Массив не может содержать пустые (Null) значения.
  • Количество элементов не может превышать 5461.

Чтобы избежать этих ограничений, рекомендую использовать пользовательскую функцию TransposeArray:

Sub ПримерИспользования()
    ИсходныйМассив = ActiveSheet.UsedRange.Offset(1).Value
    ТранспонированныйМассив = TransposeArray(ИсходныйМассив)
End Sub

Код самой функции:

Function TransposeArray(ByVal arr As Variant) As Variant
    ' Пользовательская функция для транспонирования массива
    Dim tempArray As Variant
    ReDim tempArray(LBound(arr, 2) To UBound(arr, 2), LBound(arr, 1) To UBound(arr, 1))
    For X = LBound(arr, 2) To UBound(arr, 2)
        For Y = LBound(arr, 1) To UBound(arr, 1)
            tempArray(X, Y) = arr(Y, X)
        Next Y
    Next X
    TransposeArray = tempArray
End Function
  • 32223 просмотра

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

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

Источник

Andre’s answer referring to Chip Pearson’s function I believe the +1 in the for loop is in error that in cases of LBound and UBound not BOTH being EVEN or BOTH being ODD results in the mid point reversal being reverted. i.e. the difference between LBound and UBound being ODD.

Consider 0 = LBound and 9 = UBound.

9 + 1 = 10 / 2 = 5

So the loop will be for Ndx = 0 to 5. That is 6 iterations. One iteration too many.

Results in the following swaps.
Ndx = 0, Ndx2 = 9: 0<>9
Ndx = 1, Ndx2 = 8: 1<>8
Ndx = 2, Ndx2 = 7: 2<>7
Ndx = 3, Ndx2 = 6: 3<>6
Ndx = 4, Ndx2 = 5: 4<>5
Ndx = 5, Ndx2 = 4: 5<>4

So the mid point elements 4 and 5 are swapped, then swapped back.
Resulting in the order of: 9,8,7,6,4,5,3,2,1,0

Also LBound should be added to the UBound, not subtracted. If subtracted then it only works for LBound of zero. Consider 50 = LBound, 100 = UBound. That would result in For Ndx = 50 to 25. Note, this is supposed to be a FROM, TO calculation not an iterations count calculation.

Here is my functions for reversing one and two dimensional arrays.
They are also able to optionally retain a specified number of header rows. 

' Reverse array (one dimensional), optionally retain header rows.
Private Sub Reverse_Array_1d(ByRef Ary As Variant, Optional Header_Rows As Integer = 0)

 Dim Dimension_Y As Integer     ' Rows (height)
 Dim Y_first As Long
 Dim Y_last As Long
 Dim Y_last_plus_Y_first As Long
 Dim Y_next As Long

 Dimension_Y = 1
 Y_first = LBound(Ary, Dimension_Y) + Header_Rows
 Y_last = UBound(Ary, Dimension_Y)
 Y_last_plus_Y_first = Y_last + Y_first

 Dim tmp As Variant

 For Y = Y_first To Y_last_plus_Y_first / 2
    Y_next = Y_last_plus_Y_first - Y
    tmp = Ary(Y_next)
    Ary(Y_next) = Ary(Y)
    Ary(Y) = tmp
 Next

End Sub

ReDim Ary(0 To 9) As Variant
Header_Rows = 1
Call Reverse_1d_Array(Ary, CInt(Header_Rows))

' Reverse array (two dimensional), optionally retain header rows.
Private Sub Reverse_Array_2d(ByRef Ary As Variant, Optional Header_Rows As Integer = 0)

 Dim Dimension_Y As Integer     ' Rows (height)
 Dim Y_first As Long
 Dim Y_last As Long
 Dim Y_last_plus_Y_first As Long
 Dim Y_next As Long

 Dimension_Y = 1
 Y_first = LBound(Ary, Dimension_Y) + Header_Rows
 Y_last = UBound(Ary, Dimension_Y)
 Y_last_plus_Y_first = Y_last + Y_first

 Dim Dimension_X As Integer      ' Columns (width)
 Dim X_first As Long
 Dim X_last As Long

 Dimension_X = 2
 X_first = LBound(Ary, Dimension_X)
 X_last = UBound(Ary, Dimension_X)

 ReDim tmp(X_first To X_last) As Variant

 For Y = Y_first To Y_last_plus_Y_first / 2
    Y_next = Y_last_plus_Y_first - Y
    For X = X_first To X_last
        tmp(X) = Ary(Y_next, X)
        Ary(Y_next, X) = Ary(Y, X)
        Ary(Y, X) = tmp(X)
    Next
 Next

End Sub

ReDim Ary(0 To 9, 0 To 3) As Variant
Header_Rows = 1
Call Reverse_2d_Array(Ary, CInt(Header_Rows))

Источник

Транспонирование диапазонов и двумерных массивов в VBA Excel с помощью метода WorksheetFunction.Transpose. Синтаксис метода, примеры транспонирования.

WorksheetFunction.Transpose – это метод, который преобразует вертикальный диапазон ячеек (или двумерный массив) в горизонтальный, или наоборот, и возвращает его.

Метод WorksheetFunction.Transpose работает следующим образом: первая строка исходного диапазона (массива) становится первым столбцом нового диапазона (массива), вторая строка становится вторым столбцом и т.д.

Размерность диапазона, которому присваивается транспонированный диапазон, должна соответствовать его размерности. Количество строк нового диапазона должно соответствовать числу столбцов исходного, а количество столбцов нового – числу строк исходного.

Если транспонированный диапазон присваивается массиву, размерность определяется автоматически.

Синтаксис и параметры

WorksheetFunction.Transpose(Arg1)
Параметры Описание
Arg1 Обязательный параметр. Диапазон ячеек рабочего листа или двумерный массив, который необходимо транспонировать.

Примеры транспонирования

В примерах ниже транспонируется диапазон «A1:C8» в «A11:H13», как на изображении:

Транспонированный диапазон

Транспонирование диапазона

Простое транспонирование диапазона:

Sub Primer1()

    Range(«A11:H13») = WorksheetFunction.Transpose(Range(«A1:C8»))

End Sub

Транспонирование диапазона, когда размеры исходного диапазона неизвестны, а известно, что он начинается с ячейки «A1» и новый диапазон следует разместить ниже исходного через две пустые строки:

Sub Primer2()

Dim r As Long, c As Long

    ‘Определяем количество строк в исходном диапазоне

    r = Range(«A1»).CurrentRegion.Rows.Count

    ‘Определяем количество столбцов в исходном диапазоне

    c = Range(«A1»).CurrentRegion.Columns.Count

    ‘В первой половине выражения вычисляем координаты нового диапазона

    Range(Cells(r + 3, 1), Cells(r + 2 + c, r)) = WorksheetFunction.Transpose(Range(Cells(1, 1), Cells(r, c)))

End Sub

Транспонирование массива

В этом примере двумерный массив создается на основе диапазона ячеек на рабочем листе, и новый массив выгружается на рабочий лист исключительно для наглядности, чтобы результат транспонирования можно было увидеть сразу:

Sub primer3()

Dim myArr1, myArr2

    myArr1 = Range(«A1:C8»)

    myArr2 = WorksheetFunction.Transpose(myArr1)

    Range(«A11:H13») = myArr2

End Sub
Источник

Return to VBA Code Examples

This tutorial will teach you how to transpose an array using VBA.

Transpose Array

This function will Transpose a 2-dimensional array:

Function TransposeArray(MyArray As Variant) As Variant
    Dim x As Long, y As Long
    Dim maxX As Long, minX As Long
    Dim maxY As Long, minY As Long
    
    Dim tempArr As Variant
    
    'Get Upper and Lower Bounds
    maxX = UBound(MyArray, 1)
    minX = LBound(MyArray, 1)
    maxY = UBound(MyArray, 2)
    minY = LBound(MyArray, 2)
    
    'Create New Temp Array
    ReDim tempArr(minY To maxY, minX To maxX)
    
    'Transpose the Array
    For x = minX To maxX
        For y = minY To maxY
            tempArr(y, x) = MyArray(x, y)
        Next y
    Next x
    
    'Output Array
    TransposeArray = tempArr
    
End Function

Sub TestTransposeArray()
    Dim testArr(1 To 3, 1 To 2) As Variant
    Dim outputArr As Variant
    
    'Assign Array Values
    testArr(1, 1) = "Steve"
    testArr(1, 2) = "Johnson"
    testArr(2, 1) = "Ryan"
    testArr(2, 2) = "Johnson"
    testArr(3, 1) = "Andrew"
    testArr(3, 2) = "Scott"
    
    'Call Transpose Function
    outputArr = TransposeArray(testArr)
    
    'Test Output
    MsgBox outputArr(2, 1)

End Sub

To test this function, call the procedure TestTransposeArray: here an initial array testArr is created and outputArr is the final transposed array.

WorksheetFunction.Transpose

Instead, you might want to transpose an array to Excel. To do so, you can use the Excel Transpose Worksheet Function.

This procedure will transpose a 2D array to an Excel range using the Transpose Worksheet Function:

Sub TestTransposeArray_Worksheetfx()
    Dim maxX As Long, minX As Long
    Dim maxY As Long, minY As Long
    
    'Create Array and Assign Values
    Dim MyArray(1 To 3, 1 To 2) As Variant
    
    MyArray(1, 1) = "Steve"
    MyArray(1, 2) = "Johnson"
    MyArray(2, 1) = "Ryan"
    MyArray(2, 2) = "Johnson"
    MyArray(3, 1) = "Andrew"
    MyArray(3, 2) = "Scott"
    
    'Get Upper and Lower Bounds
    maxX = UBound(MyArray, 1)
    minX = LBound(MyArray, 1)
    maxY = UBound(MyArray, 2)
    minY = LBound(MyArray, 2)
    
    'Transpose Array to Excel
    Range("a1").Resize(maxY - minY + 1, maxX - minX + 1).Value = _
      Application.WorksheetFunction.Transpose(MyArray)

End Sub

VBA Coding Made Easy

Stop searching for VBA code online. Learn more about AutoMacro — A VBA Code Builder that allows beginners to code procedures from scratch with minimal coding knowledge and with many time-saving features for all users!
vba save as

Learn More!

Источник

RRS feed

  • Remove From My Forums

  • Question

  • I have the following code, which based on the logic it should work.

    I want t to be (4,3,2,1), but at the end of the loop i get t=(4,3,3,4)

    Sub try()
    Dim t As Variant
    t = Array(1, 2, 3, 4)
    a = UBound(t)
    For k = 0 To a
    t(k) = t(a — k)
    Next k
    End Sub

    Any ideas. Thanks.

Answers

  • Try this:

    For k = 0 To a  2
   Dim z
   z = t(k)
   t(k) = t(a - k)
   t(a - k) = z
Next k

    • Marked as answer by
      Walter David Sanchez
      Sunday, May 28, 2017 5:04 AM

All replies

  • Try this:

    For k = 0 To a  2
   Dim z
   z = t(k)
   t(k) = t(a - k)
   t(a - k) = z
Next k

    • Marked as answer by
      Walter David Sanchez
      Sunday, May 28, 2017 5:04 AM

  • Thanks a lot. It just  worked.

Источник

Like this post? Please share to your friends:
  • Vba excel перенести текст в ячейке
  • Vba excel перебрать все файлы в папке
  • Vba excel перемещение ячеек
  • Vba excel перебрать все листы в книге excel
  • Vba excel перемещение по строкам