Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Произвести копирование массива и его вставку в строку с транспонированием значений столбцов
 
#1
31.07.2020 14:01:13
Добрый день!

Есть задача по копированию и вставке с транспонированием массива.
1) из Массива 1 получается Массив 2
2) из Массива 3 получается Массив 4
3) из Массива 5 получается Массив 6

Файл прилагается.

Как сделать это с помощью VBA (array). Даже не знаю какой код применить.
 
 
 
#2
31.07.2020 14:35:42
Доброе время суток
Вариант для 1 в 2 и 3 в 4
Код
Public Sub RectangleToRowArray()
    Dim vData As Variant, vOut() As Variant
    Dim i As Long, k As Long, c As Long
    vData = Selection.Value
    ReDim vOut(1 To 1, 1 To UBound(vData, 1) * UBound(vData, 2))
    c = 0
    For i = 1 To UBound(vData, 2)
        For k = 1 To UBound(vData, 1)
            c = c + 1
            vOut(1, c) = vData(k, i)
        Next
    Next
    Selection.Parent.Parent.Worksheets.Add.Range("A1").Resize(1, UBound(vData, 1) * UBound(vData, 2)).Value = vOut
End Sub

Обратно по аналогии
 
 
 
#3
31.07.2020 15:03:37
массивы 2, 4, 6 можно получить с помощью функции
Код
' *****************************************************************************
' преобразование двумерного массива ar
' в двумерный массив размерами (1 To rCnt, 1 To cCnt)
' с отбором значений из исходного по строкам (или колонкам при ByRow = False)
'
Function TransFormArray(ar, rCnt, cCnt, Optional ByRow = True)
  Dim i&, j&, b, br&, bc&, f&
  ReDim b(1 To rCnt, 1 To cCnt): br = 1: bc = 1: f = IIf(ByRow, 1, 2)
  For i = LBound(ar, f) To UBound(ar, f)
    For j = LBound(ar, 3 - f) To UBound(ar, 3 - f)
      If ByRow Then b(br, bc) = ar(i, j) Else b(br, bc) = ar(j, i)
      br = br + 1
      If br > rCnt Then _
      br = 1: bc = bc + 1: If bc > cCnt Then TransFormArray = b: Exit Function
    Next
  Next
  TransFormArray = b
End Function
Изменено: Ігор Гончаренко - 01.08.2020 00:34:07
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#4
17.08.2020 17:30:46
Ігор Гончаренко, Добрый вечер, добавил Вашу функцию в Insert module. Для получения массива 2  в ячейку ввожу  =TransFormArray(A3:C4), Пишет #ЗНАЧ!. потом протягиваю. Все равно пишет #ЗНАЧ!.
 
 
 
#5
17.08.2020 17:59:47
 =TransFormArray(A3:C4)
функции нужны еще 2 параметра: сколько строк, колонок должнно получиться в итоговом массиве
вы указали только исходный масссив и не указываете что должно получиться на выходе (полагаете макрос сам догадается, что вам нужно?)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#6
17.08.2020 18:09:28
Ігор Гончаренко,Вы правы)) Написал =TransFormArray((A3:C4);1;6), пишет  #ЗНАЧ!. А как выглядит должна функция в ячейке?
 
 
 
#7
17.08.2020 18:34:24
выполните Banzay
Код
Sub Banzay()
  Dim b
  b = TransFormArray([a3:c4].Value, 1, 6, False)
  [i3].Resize(UBound(b), UBound(b, 2)) = b
End Sub

Function TransFormArray(ar, rCnt, cCnt, Optional ByColunm = True)
  Dim i&, j&, b, br&, bc&, f&
  ReDim b(1 To rCnt, 1 To cCnt): br = 1: bc = 1: f = IIf(ByColunm, 1, 2)
  For i = LBound(ar, f) To UBound(ar, f)
    For j = LBound(ar, 3 - f) To UBound(ar, 3 - f)
      If ByColunm Then b(br, bc) = ar(i, j) Else b(br, bc) = ar(j, i)
      br = br + 1
      If br > rCnt Then _
      br = 1: bc = bc + 1: If bc > cCnt Then TransFormArray = b: Exit Function
    Next
  Next
  TransFormArray = b
End Function
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#8
17.08.2020 18:48:54
Ігор Гончаренко, Прикольно)) Работает. 5 баллов из 5. Готов отправить Вам Donate 300 руб. на Ваш кошелек Яндекc за отличный и оперативный ответ.


P .S. Donate ежегодно направляю только Wikipedia, Kiwix.
 
 
 
#9
17.08.2020 19:00:45
спасибо)
№ кошелька указан в профиле
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#10
17.08.2020 19:01:40
Ігор Гончаренко, Яндекс кошелек на Вашем профиле рабочий? А то Paypal не работает.
 
 
 
#11
17.08.2020 19:22:12
Ігор Гончаренко, Donate 303 ₽ выполнен. Хорошего дня и отличного настроения.
 
 
 
Страницы: 1
Наверх