0

如果有人能给我一些帮助,我将不胜感激。

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

  1. 选择 2 个不同的 csv 文件,它们代表 2 个相同列和相同行的矩阵。
  2. 将矩阵中的每个相应单元格相乘。
  3. 返回结果。

不幸的是,我似乎无法让它运行。知道我做错了什么吗?请看下面的代码。非常感谢。 代码从以前的版本更改

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
4

2 回答 2

0

谢谢大家的帮助。我的代码没有打印结果的原因是我有这个:If ANCOLUMNS <> BNROWS Then: GoTo ERROR_LABEL. 同时,我使用了两个 70*120 的矩阵,所以它不断退出函数,就像我编写的那样!!全部更正并且工作正常。非常感谢你的帮助

于 2012-12-04T10:51:15.010 回答
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 ;-)

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

于 2012-12-04T08:33:38.497 回答