Question

我不是数学，但我需要在VBA中解决一些映射函数。我有字符串数组Divisions，它由表单上的复选框填充（数组由字符串填充或零，如图所示）。我需要找到一些函数将我的数组（左边，总是3x4维度）转换为右边的数组（nx1维度）。以下是示例：你有什么想法？在VBA中是否存在某种地图功能，可以做什么，我希望做什么？谢谢

Answer 1

将执行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 2

不幸的是，我认为没有这样的功能。你必须自己写。或者，您可以在这里查看http://www.cpearson.com/excel/vbaarrays.htm

Answer 3

在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 4

几乎等于Jochen的答案。在这里，我检查数组的元素是否为非零，然后将它们组合起来检查字符串的长度。如果它等于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

Excel VBA将二维数组传输到一维

4 个答案: