VBA Store 1ユニークの場合のみ新しい行にD配列を追加

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

は、あなたが（トリムする必要がないに頼ることができれば）ワークシート上のデータを実装する方が簡単だろう....

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

ティム・ウィリアムズは、これらのTrim機能に関する権利です。

私は任意の順序ですべての配列項目の一致を探していて、配列項目のいくつかが空または空文字列（これは数えられない？）。

.Textプロパティは、シートセルに表示されているものだけを表示するようにする必要があります。例えば####は可能な値にすることができます。

最後に、Excelシートが大きく、多くの配列をテストしている場合は、毎回そのシートから値を読み取るのにかなりの時間がかかります。あなたはそれらをある種のデータ記憶オブジェクトに読み込んで、それに対するあなたの価値の存在をテストする方が良いかもしれません。私はCollectionを使用したことがわかります。すべてのすべてで

、そして、あなたのコードは、最初のモジュールレベルの変数にデータを読み込み、あなたのモジュールで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