Question

我要在工作表中存储大量文字。我编写了一个子例程，它将数组与Excel工作表的范围进行比较。我沿着整个工作表循环检查一路上的值。

某些东西似乎无法正常工作。

示例数组输入

( "Dog" , "Cat" , "6" , "Some string like this" )

此输入数组的UBound可能会改变。

我的代码似乎没有准确地比较3个字段。也许某些东西与我的阵列计数混在一起，或者如果有人对如何实现这一点有任何更好的想法，我将不胜感激任何帮助。

Public Sub storeData(sArray() As Variant)
Dim i As Integer
Dim vLastRow As Integer
Dim vRow As Integer
Dim test As Range
Dim Destination As Range
Dim wl As Worksheets

vRow = 1
vLastRow = Worksheets("word List").Range("A" & Rows.Count).End(xlUp).Row
Debug.Print vLastRow
For vRow = 1 To vLastRow
    RollingCheck = 0
    For i = 0 To UBound(sArray)
        Set test = Worksheets("word List").Cells(vRow, i + 1)
        If (Trim(test.text) = Trim(sArray(i)) & Len(test) > 0) Then  
            ' To speed it up I added the len() command in to avoid null string. 
            ' Ideally I wish I could only cycle through rows which have the same 
            ' number of columns to array indicies because this will be dynamic
            RollingCheck = RollingCheck + 1
            Debug.Print CStr(vRow) & CStr(RollingCheck) & _
                Worksheets("word List").Cells(vRow, i + 1).text & "=" & sArray(i)
            If (RollingCheck = UBound(sArray)) Then
                MsgBox "exit" & CStr(vRow)
                ' All columns of the worksheet = each index of the array 
                ' thus exit the sub
                Exit Sub 
            End If
        End If
    Next i
Next vRow

' Value no found through cycling the work sheet, 
' thus store the array within the next blank row
Set Destination = Worksheets("Word List").Range("A" & vRow)
Set Destination = Destination.Resize(1, UBound(sArray))
Destination.value = sArray
MsgBox "store" & CStr(vRow)

Answer 1

如果您可以依赖不需要Trim（）工作表上的数据，那么实现起来会更简单....

Public Sub storeData(sArray() As Variant)
    Dim i As Integer
    Dim vLastRow As Integer
    Dim vRow As Integer
    Dim wl As Worksheet, rw As Range, haveMatch As Boolean

    Set wl = Worksheets("word List")

    vLastRow = wl.Range("A" & Rows.Count).End(xlUp).Row
    Debug.Print vLastRow

    For vRow = 1 To vLastRow
        Set rw = wl.Rows(vRow)
        'is this a candidate row?
        If Trim(rw.Cells(1).Value) = Trim(sArray(0)) And _
               Application.CountA(rw) = UBound(sArray) + 1 Then

            haveMatch = True
            For i = 1 To UBound(sArray)
                If Trim(rw.Cells(i).Value) <> Trim(sArray(i)) Then
                    haveMatch = False
                    Exit For
                End If
            Next i
            If haveMatch Then Exit Sub

        End If
    Next vRow

    wl.Cells(vLastRow + 1, 1).Resize(1, UBound(sArray) + 1).Value = sArray
    MsgBox "stored: " & CStr(vLastRow + 1)

End Sub

Answer 2

蒂姆·威廉姆斯对于那些.Text职能是正确的。

我提出了第二个答案，因为它看起来好像你正在寻找任何顺序的所有数组项的匹配，并且某些数组项是空的或空字符串（不计算？）。

您还应该避免Collection属性，因为它只会显示表格单元格中可见的内容。因此，####可能是一个可能的值，例如。

最后一点是，如果您的Excel工作表很大并且您正在测试许多数组，那么每次从该工作表中读取值都相当耗时。你最好将它们读入某种数据存储对象，并根据它来测试你的值的存在。你会看到我使用了Sub。

总而言之，您的代码可能就是这样......首先在模块中创建一个Option Explicit Private mSheetData As Collection Private Sub ReadExcelData() Dim sheetArr As Variant Dim lineData As Collection Dim r As Long, c As Long 'Read the Excel sheet into a collection - you could be more sophisticated than UsedRange sheetArr = ThisWorkbook.Worksheets("word List").UsedRange.Value2 Set mSheetData = New Collection For r = 1 To UBound(sheetArr, 1) Set lineData = New Collection For c = 1 To UBound(sheetArr, 2) If Not IsEmpty(sheetArr(r, c)) Then On Error Resume Next 'avoids error if it's a duplicate in the line lineData.Add True, Trim(CStr(sheetArr(r, c))) On Error GoTo 0 End If Next If lineData.Count > 0 Then mSheetData.Add lineData Next End Sub，将数据读入模块级变量：

Private Function HasMatch(inputArr() As Variant) As Boolean
    Dim c As Long
    Dim lineData As Collection

    For Each lineData In mSheetData
        For c = LBound(inputArr) To UBound(inputArr)
            If Not IsEmpty(inputArr(c)) Then
                If Len(inputArr(c)) > 0 Then
                    HasMatch = False
                    On Error Resume Next
                    HasMatch = lineData(Trim(CStr(inputArr(c))))
                    On Error GoTo 0
                    If Not HasMatch Then Exit For
                End If
            End If
        Next
        If HasMatch Then Exit Function
    Next

End Function

然后添加一个测试样本数组是否存在的函数：

Public Sub RunMe()
    Dim rng As Range
    Dim sample() As Variant

    'Read the data into the array
    ReadExcelData

    'Acquire the next blank line
    With ThisWorkbook.Worksheets("word List")
        Set rng = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
    End With

    'Test your line(s)
    sample = Array("Dog", "Cat", "6", "Some string like this")
    If Not HasMatch(sample) Then
        rng.Resize(, UBound(sample) - LBound(sample) + 1).Value = sample
        Set rng = rng.Offset(1) 'offset the next blank line ready for next input
    End If

End Sub

然后你就有了一个调用例程，如下所示：

case a:String

仅当唯一

2 个答案: