使用VBA乘以矩阵并将结果保存在文本文件中

时间:2012-12-04 03:43:48

标签: excel vba excel-vba

如果有人能给我一些帮助,我真的很感激。

我对vba非常熟悉,我可以编写简单的代码,也可以自定义其他代码。我已经编写/定制/复制了几段vba代码来执行以下操作(确认复制的源代码):

  1. 选择2个不同的csv文件,这些文件代表同一列和相同行的2个矩阵。
  2. 将矩阵中的每个单元格相乘。
  3. 返回结果。
  4. 不幸的是我似乎无法让它运行。 知道我没做错的吗? 请参阅下面的代码。非常感谢。 代码已从先前版本更改

    Public Sub doIt()
        Dim sourceFile As String
        Dim destinationFile As String
        Dim data As Variant
        Dim result As Variant
        Dim sourceFile2 As String
        Dim datarain As Variant
    
        sourceFile = "C:\file1.csv"
        sourceFile2 = "C:\file2.csv"
        destinationFile = "C:\file3.txt"
        data = getDataFromFile(sourceFile, ",")
        datarain = getDataFromFile(sourceFile2, ",")
        If Not isArrayEmpty(data) Then
           result = MMULT2_FUNC(data, datarain)
           writeToCsv result, destinationFile, ","
        Else
           MsgBox ("Empty file")
        End If
    End Sub
    
    Function MMULT2_FUNC(ByRef ADATA_RNG As Variant, _
    ByRef BDATA_RNG As Variant)
    
    Dim i As Long
    Dim j As Long
    Dim k As Long
    
    Dim ANROWS As Long
    Dim BNROWS As Long
    
    Dim ANCOLUMNS As Long
    Dim BNCOLUMNS As Long
    
    Dim ADATA_MATRIX As Variant
    Dim BDATA_MATRIX As Variant
    
    Dim TEMP_MATRIX As Variant
    
    On Error GoTo ERROR_LABEL
    
    ADATA_MATRIX = ADATA_RNG
    BDATA_MATRIX = BDATA_RNG
    
    ANROWS = UBound(ADATA_MATRIX, 1)
    BNROWS = UBound(BDATA_MATRIX, 1)
    
    ANCOLUMNS = UBound(ADATA_MATRIX, 2)
    BNCOLUMNS = UBound(BDATA_MATRIX, 2)
    
    If ANCOLUMNS <> BNROWS Then: GoTo ERROR_LABEL
    
    ReDim TEMP_MATRIX(1 To ANROWS, 1 To BNCOLUMNS)
    
    For i = 1 To ANROWS
        For j = 1 To BNCOLUMNS
            TEMP_MATRIX(i, j) = 0
            For k = 1 To ANCOLUMNS
                TEMP_MATRIX(i, j) = TEMP_MATRIX(i, j) + ADATA_MATRIX(i, k) * _
                                    BDATA_MATRIX(k, j)
            Next k
        Next j
    Next i
    
    MMULT2_FUNC = TEMP_MATRIX
    
    Exit Function
    ERROR_LABEL:
    MMULT2_FUNC = Err.Number
    End Function
    
    
    Public Sub writeToCsv(parData As Variant, parFileName As String, parDelimiter As String)
    
        If getArrayNumberOfDimensions(parData) <> 2 Then Exit Sub
    
        Dim i As Long
        Dim j As Long
        Dim FileNum As Long
        Dim locLine As String
        Dim locCsvString As String
    
        FileNum = FreeFile
        If Dir(parFileName) <> "" Then Kill (parFileName)
        Open parFileName For Binary Lock Read Write As #FileNum
    
        For i = LBound(parData, 1) To UBound(parData, 1)
          locLine = ""
          For j = LBound(parData, 2) To UBound(parData, 2)
            If IsError(parData(i, j)) Then
              locLine = locLine & "#N/A" & parDelimiter
            Else
              locLine = locLine & parData(i, j) & parDelimiter
            End If
          Next j
          locLine = Left(locLine, Len(locLine) - 1)
          If i <> UBound(parData, 1) Then locLine = locLine & vbCrLf
          Put #FileNum, , locLine
        Next i
    
    error_handler:
        Close #FileNum
    
    End Sub
    
    Public Function isArrayEmpty(parArray As Variant) As Boolean
    'Returns false if not an array or dynamic array that has not been initialised (ReDim) or has been erased (Erase)
    
      If IsArray(parArray) = False Then isArrayEmpty = True
      On Error Resume Next
      If UBound(parArray) < LBound(parArray) Then isArrayEmpty = True: Exit Function Else: isArrayEmpty = False
    
    End Function
    
    Public Function getArrayNumberOfDimensions(parArray As Variant) As Long
    'Returns the number of dimension of an array - 0 for an empty array.
    
        Dim i As Long
        Dim errorCheck As Long
    
        If isArrayEmpty(parArray) Then Exit Function 'returns 0
    
        On Error GoTo FinalDimension
        'Visual Basic for Applications arrays can have up to 60000 dimensions
        For i = 1 To 60001
            errorCheck = LBound(parArray, i)
        Next i
    
        'Not supposed to happen
        getArrayNumberOfDimensions = 0
        Exit Function
    
    FinalDimension:
        getArrayNumberOfDimensions = i - 1
    
    End Function
    
    Private Function getDataFromFile(parFileName As String, parDelimiter As String, Optional parExcludeCharacter As String = "") As Variant
    'parFileName is supposed to be a delimited file (csv...)
    'parDelimiter is the delimiter, "," for example in a comma delimited file
    'Returns an empty array if file is empty or can't be opened
    'number of columns based on the line with the largest number of columns, not on the first line
    'parExcludeCharacter: sometimes csv files have quotes around strings: "XXX" - if parExcludeCharacter = """" then removes the quotes
    
    
      Dim locLinesList() As Variant
      Dim locData As Variant
      Dim i As Long
      Dim j As Long
      Dim locNumRows As Long
      Dim locNumCols As Long
      Dim fso As Variant
      Dim ts As Variant
      Const REDIM_STEP = 10000
    
      Set fso = CreateObject("Scripting.FileSystemObject")
    
      On Error GoTo error_open_file
      Set ts = fso.OpenTextFile(parFileName)
      On Error GoTo unhandled_error
    
      'Counts the number of lines and the largest number of columns
      ReDim locLinesList(1 To 1) As Variant
      i = 0
      Do While Not ts.AtEndOfStream
        If i Mod REDIM_STEP = 0 Then
          ReDim Preserve locLinesList(1 To UBound(locLinesList, 1) + REDIM_STEP) As Variant
        End If
        locLinesList(i + 1) = Split(ts.ReadLine, parDelimiter)
        j = UBound(locLinesList(i + 1), 1) 'number of columns
        If locNumCols < j Then locNumCols = j
        If j = 13 Then
          j = j
        End If
        i = i + 1
      Loop
    
      ts.Close
    
      locNumRows = i
    
      If locNumRows = 0 Then Exit Function 'Empty file
    
      ReDim locData(1 To locNumRows, 1 To locNumCols + 1) As Variant
    
      'Copies the file into an array
      If parExcludeCharacter <> "" Then
    
        For i = 1 To locNumRows
          For j = 0 To UBound(locLinesList(i), 1)
            If Left(locLinesList(i)(j), 1) = parExcludeCharacter Then
              If Right(locLinesList(i)(j), 1) = parExcludeCharacter Then
                locLinesList(i)(j) = Mid(locLinesList(i)(j), 2, Len(locLinesList(i)(j)) - 2)       'If locTempArray = "", Mid returns ""
              Else
                locLinesList(i)(j) = Right(locLinesList(i)(j), Len(locLinesList(i)(j)) - 1)
              End If
            ElseIf Right(locLinesList(i)(j), 1) = parExcludeCharacter Then
              locLinesList(i)(j) = Left(locLinesList(i)(j), Len(locLinesList(i)(j)) - 1)
            End If
            locData(i, j + 1) = locLinesList(i)(j)
          Next j
        Next i
    
      Else
    
        For i = 1 To locNumRows
          For j = 0 To UBound(locLinesList(i), 1)
            locData(i, j + 1) = locLinesList(i)(j)
          Next j
        Next i
    
      End If
    
      getDataFromFile = locData
    
      Exit Function
    
    error_open_file:                 'returns empty variant
    unhandled_error:                 'returns empty variant
    
    End Function
    

2 个答案:

答案 0 :(得分:0)

尽管我个人认为你的代码在某些情况下可以改进,但它在语法上执行没有问题(在小矩阵上)。

我的测试数据

1,2,3       2,3,4      20,26,32
2,3,4   X   3,4,5  =   29,38,47
3,4,5       4,5,6      38,50,62

结果整齐地写入CSV。

只有明显的问题(在Win 7上这里!)是Sub writeToCsv -> Open parFileName ...由于缺少对根目录的写权限而失败。这可能不是XP的问题。

在另一个令牌上,我的印象是代码可以改进,但我可能不理解代码某些部分背后的基本原理。

实施例

Function MMULT2_FUNC(ByRef ADATA_RNG As Variant, ByRef BDATA_RNG As Variant) ' missing type of result

Private Function getDataFromFile(...)
...
If j = 13 Then
    j = j
End If ' whow ... if j <> 13 then j again equals j ;-)

在输入和输出上找到矩阵的上下界可以大大简化......

答案 1 :(得分:0)

谢谢大家的帮助。我的代码没有打印结果的原因是我有这个:If ANCOLUMNS <> BNROWS Then: GoTo ERROR_LABEL。与此同时,我使用了两个70 * 120的矩阵,所以它不断退出功能,因为我已经编程完成了!!纠正了一切并且工作正常。非常感谢您的帮助