Excel VBA переносит двумерный массив на один размер

Question

Я не математик, но мне нужно решить некоторую функцию отображения в VBA. У меня есть строковые массивы Divisions, которые заполняются флажками check on the form (массив заполняется строкой или нулем, как на картинке). Мне нужно найти некоторую функцию, которая преобразует мой массив (слева, всегда размер 3x4) в массив справа (размер nx1). Вот примеры: Есть ли у вас идеи? Существует ли какая-то функция отображения в VBA, что может сделать, чего я хочу? Спасибо

Answer 1

К сожалению, я не думаю, что есть такая функция. Вам придется написать это самостоятельно. Кроме того, вы можете посмотреть здесь http://www.cpearson.com/excel/vbaarrays.htm

Answer 2

отредактированный после уточнений OP в

вы могли бы пойти, как следующим образом:

Option Explicit 

Sub main() 
    Dim myMatrix(1 To 3, 1 To 4) As Variant 
    Dim myArray As Variant 
    Dim i As Long, j As Long, k As Long, nRows As Long, nCols As Long 

    'fill Matrix with some values 
    myMatrix(1, 1) = 1: myMatrix(1, 2) = 2: myMatrix(1, 3) = 3: myMatrix(1, 4) = 4 
    myMatrix(2, 1) = 5: myMatrix(2, 2) = 6: myMatrix(2, 3) = 7: myMatrix(2, 4) = 8 
    myMatrix(3, 1) = 9: myMatrix(3, 2) = 10: myMatrix(3, 3) = 11: myMatrix(3, 4) = 12 

    myArray = GetArray(myMatrix) '<~~ fill Array 

    MsgBox GetArrayItem(myArray, 2, 3) '<~~ get Array item corresponding to Matrix(2,3) 
    MsgBox GetMatrixItem(myMatrix, 7) '<~~ get Matrix item corresponding to Array(7)   
End Sub 


Function GetArrayItem(myArray As Variant, i As Long, j As Long) As Variant 
    'mapping from Matrix to array 
    Dim k As Long 

    k = (i - 1) * 4 + j '<~~ equivalent array index given matrix indexes 

    GetArrayItem = myArray(k) 
End Function 


Function GetMatrixItem(myMatrix() As Variant, k As Long) As Variant 
    'mapping from Array to Matrix 
    Dim i As Long, j As Long, nCols As Long 

    nCols = UBound(myMatrix, 2) - LBound(myMatrix, 2) + 1 '<~~get Matrix columns number 
    i = k Mod nCols - 1 '<~~ matrix row index given array index 
    j = k - (i - 1) * nCols '<~~ matrix column index given array index 

    GetMatrixItem = myMatrix(i, j) 
End Function 


Function GetArray(myMatrix() As Variant) As Variant 
    'returns an Array filled with a Matrix content 
    Dim myArray() As Variant 
    Dim i As Long, j As Long, k As Long, nRows As Long, nCols As Long 

    nRows = UBound(myMatrix, 1) - LBound(myMatrix, 1) + 1 '<~~get Matrix rows number 
    nCols = UBound(myMatrix, 2) - LBound(myMatrix, 2) + 1 '<~~get Matrix columns number 

    ReDim myArray(1 To nRows * nCols) '<~~dim Array accordingly to Matrix dimensions 

    'loop through Matrix elements to fill Array 
    For i = 1 To nRows 
     For j = 1 To nCols 
      myArray((i - 1) * 4 + j) = myMatrix(i, j) 
     Next j 
    Next i 

    GetArray = myArray '<~~return array 
End Function 

Answer 3

3 простых петли будут делать:

Option Explicit 
Option Base 1 

Sub Test() 
Dim arr, vec() As String, dmy As String 
Dim r1 As Integer, r2 As Integer, r3 As Integer, counter As Integer 
arr = Range("A1:D3").Value 
    For r1 = 1 To 4 
     For r2 = 1 To 4 
     For r3 = 1 To 4 
      dmy = Join(Array(arr(1, r1), arr(2, r2), arr(3, r3), " ")) 
      If InStr(dmy, "0") = 0 Then 
       counter = counter + 1 
       ReDim Preserve vec(counter) 
       vec(counter) = dmy 
      End If 
     Next 
     Next 
    Next 
Range("G1").Resize(counter, 1).Value = Application.WorksheetFunction.Transpose(vec) 
End Sub 

Answer 4

Почти равны к ответу Йохена. Здесь я проверяю, отличен ли элемент массива от нуля, а затем объединить их для проверки длины строки. Если он равен 3, то в противном случае продолжите печать.

Option Explicit 

Sub test() 
Dim base(2, 3), ip As Range, op As Range, output(64), i As Integer, j As Integer, k As Integer, l As Integer, temp As String 
l = 0 

Set ip = Application.InputBox(Prompt:="Please select a first cell of input range", Title:="Specify Input range", Type:=8) 
Set op = Application.InputBox(Prompt:="Please select a first cell of output range", Title:="Specify Output range", Type:=8) 
For i = 0 To 2 
    For j = 0 To 3 
    base(i, j) = ip.Offset(i, j).Value 
    Next j 
Next i 

For i = 0 To 3 
    If base(0, i) <> 0 Then 
     For j = 0 To 3 
      If base(1, j) <> 0 Then 
       For k = 0 To 3 
        If base(2, k) <> 0 Then 
        temp = base(0, i) & base(1, j) & base(2, k) 
         If Len(temp) = 3 Then 
          output(l) = temp 
          op.Offset(l, 0) = output(l) 
          l = l + 1 
          temp = "" 
         End If 
        End If 
       Next k 
      End If 
     Next j 
    End If 
Next i 

End Sub