Excel VBAを数えて別の値を印刷する

Question

列から異なる値の数を数え、それを別の値で印刷して別のシートに数えなければなりません。私はこのコードを使って作業していますが、何らかの理由で結果が返されていません。誰かが私がその部分を逃している場所を教えてもらえますか？

Dim rngData As Range 
Dim rngCell As Range 
Dim colWords As Collection 
Dim vntWord As Variant 
Dim Sh As Worksheet 
Dim Sh1 As Worksheet 
Dim Sh2 As Worksheet 
Dim Sh3 As Worksheet 

On Error Resume Next 

Set Sh1 = Worksheets("A") 
Set Sh2 = Worksheets("B") 
Set Sh3 = Worksheets("C") 

Sh1.Range("A2:B650000").Delete 

Set Sh = Worksheets("A") 
Set r = Sh.AutoFilter.Range 
r.AutoFilter Field:=24 
r.AutoFilter Field:=24, Criteria1:="My Criteria" 

Sh1.Range("A2:B650000").Delete 

Set colWords = New Collection 

Dim lRow1 As Long 
lRow1 = <some number> 

Set rngData = <desired range> 
For Each rngCell In rngData.Cells 
    colWords.Add colWords.Count + 1, rngCell.Value 
    With Sh1.Cells(1 + colWords(rngCell.Value), 1) 
     .Value = rngCell.Value 
     .Offset(0, 1) = .Offset(0, 1) + 1 
    End With 
Next 

は、上記の私の必要な結果が列内の各セルの出現回数をカウントし、発生数を持つ別のシートにそれを印刷、簡単な..です私の完全なコードです。ありがとう！

ありがとうございます！ ナビゲーション。

Answer 1

ないきれいなまたは最も最適な経路が、それは仕事を得るだろうと私はあなたがそれを理解することができますかなり確信している：

Option Explicit 

Sub TestCount() 

Dim rngCell As Range 
Dim arrWords() As String, arrCounts() As Integer 
Dim bExists As Boolean 
Dim i As Integer, j As Integer 

ReDim arrWords(0) 

For Each rngCell In ThisWorkbook.Sheets("Sheet1").Range("A1:A20") 
    bExists = False 

    If rngCell <> "" Then 
     For i = 0 To UBound(arrWords) 
      If arrWords(i) = rngCell.Value Then 
       bExists = True 
       arrCounts(i) = arrCounts(i) + 1 
      End If 
     Next i 

     If bExists = False Then 
      ReDim Preserve arrWords(j) 
      ReDim Preserve arrCounts(j) 

      arrWords(j) = rngCell.Value 
      arrCounts(j) = 1 

      j = j + 1 
     End If 
    End If 
Next 

For i = LBound(arrWords) To UBound(arrWords) 
    Debug.Print arrWords(i) & ", " & arrCounts(i) 
Next i 

End Sub 

A1を通じてこれがループ：A20「シート1」に。セルが空白でない場合は、単語が配列内に存在するかどうかを確認します。そうでなければ、それは1のカウントで配列にそれを加える。それが存在するならば、それは単にカウントに1を加える。これがあなたのニーズに合っていることを願っています

また、あなたのコードを見てから覚えておいてください：実質的にはOn Error Resume Nextを使用しないでください。

Answer 2

これは、辞書オブジェクトを使用すると非常に簡単で実用的です。ロジックはKittoesの答えと似ていますが、辞書オブジェクトははるかに高速で効果的です。ここでやりたいすべてのキーとアイテムの配列を出力できます。私は列Aからリストを生成するようにコードを単純化しましたが、あなたはその考えを得るでしょう。

Sub UniqueReport() 

Dim dict As Object 
Set dict = CreateObject("scripting.dictionary") 
Dim varray As Variant, element As Variant 

varray = Range("A1:A10").Value 

'Generate unique list and count 
For Each element In varray 
    If dict.exists(element) Then 
     dict.Item(element) = dict.Item(element) + 1 
    Else 
     dict.Add element, 1 
    End If 
Next 

'Paste report somewhere 
Sheet2.Range("A1").Resize(dict.Count, 1).Value = _ 
    WorksheetFunction.Transpose(dict.keys) 
Sheet2.Range("B1").Resize(dict.Count, 1).Value = _ 
    WorksheetFunction.Transpose(dict.items) 

End Sub 

それは仕組み：あなたはちょうどその辞書にそれぞれを追加し、迅速をループバリアント配列に範囲をダンプします。それが存在する場合、あなたはちょうど彼らがキー（1で始まる）と一緒に行く項目を取ると、それに1を追加します。最後に、あなたがそれらを必要とするところでユニークなリストと数を叩くだけです。辞書のオブジェクトを作成する方法は、誰でも使用できるので、コードへの参照を追加する必要はありません。