Excelマクロ

質問

お世話になります。
Excelのマクロに関する質問です。

目的としては、D列に様々な文言が入っており、
D列に記入されている各文言の数をカウントしたいと思っています。

ただし、D列の各文言が複数あった場合でも、
A列が同じ値の場合は数に含めない、という条件があります。

ex)D列に「りんご」という文言が10個あります。
　 D列に「りんご」と記入されている行のA列は、
「赤」「青」の2パターンしかありません。
⇒この場合、「2」とカウントしたいです。

現在、以下のマクロを考えています。

===========================================================
sub test()

Dim i As Long, x As Long, cnt As Long, buf As Object
'「i」「x」「cnt」を数値として定義。「buf」にD列の値を格納します。

x = 4 '4行目以降を対象としています。

Do While Cells(x, 1).Value <> "" 'A列が空白でない場合のみを対象とします。

cnt = 0 '各行のD列に入っている値の数を数えるため、まずはカウントを0にします。

i = 4 '4行目以降を対象としています。

Set buf = Cells(x, 4) ' D列の値を変数「buf」に格納します。

Do While Cells(i, 1).Value <> "" 'A列が空白でない場合のみを対象とします。

If Cells(i, 4).Value = buf And Cells(i, 1).Value <> Cells(x, 1).Value Then
　' D列の値が「buf」に格納した値と同じ、かつ、
　　　　　　' A列の値が、bufに値を格納した時と異なる場合のみ対象

cnt = cnt + 1 '数を数える対象であれば、+1します。

End If

i = i + 1 '次の行に移るために+1します。

Loop

Cells(x, 5).Value = cnt ' E列にcntに格納された値を入力

x = x + 1 '次の行に移るために+1します。

Loop

end sub
=====================================================

上記のマクロでは、E列にカウント後の数らしいものが入力されるのですが、
値が正しくないようです。

お力添えをいただけますでしょうか。
よろしくお願いいたします。

回答No.3

nobu_suzuki1 · ベストアンサー

No.2の回答をしたものですが、完全に勘違いしていたことに気付いたので作り直しました。

Sub count()

Dim Data(), Data2(), Data3() As String
Dim i, j As Long
Dim count() As Long
Dim flag(), flag2() As Boolean

i = 4

'セルAとセルDを配列に格納
While Cells(i, 4) <> ""
ReDim Preserve Data(i - 4)
Data(i - 4) = Cells(i, 1)
ReDim Preserve Data2(i - 4)
Data2(i - 4) = Cells(i, 4)
i = i + 1
Wend

ReDim flag(UBound(Data))
ReDim flag2(UBound(Data))

'重複を調べるフラグ用配列を初期化
For i = 0 To UBound(Data)
flag(i) = True
flag2(i) = True
Next

'重複するデータの場合flag配列にFalseを代入
For i = 0 To UBound(Data) - 1
For j = i + 1 To UBound(Data)
If Data(i) & Data2(i) = Data(j) & Data2(j) Then flag(j) = False
If Data2(i) = Data2(j) Then flag2(j) = False
Next
Next

'D列のデータを重複を除いて取得
ReDim Data3(0)
For i = 0 To UBound(flag2)
If flag2(i) = True Then
Data3(UBound(Data3)) = Data2(i)
ReDim Preserve Data3(UBound(Data3) + 1)
End If
Next

'カウント配列を動的に生成
ReDim count(UBound(Data3) - 1)

'Data3配列とData2配列（D列）、フラグを比較してカウント対象であればカウント
For i = 0 To UBound(count)
For j = 0 To UBound(flag)
If flag(j) And Data3(i) = Data2(j) Then
count(i) = count(i) + 1
End If
Next
Next

'カウントした個数を表示
i = 4
While Cells(i, 1) <> ""
For j = 0 To UBound(count)
If Cells(i, 4) = Data3(j) Then
Cells(i, 5) = count(j)
End If
Next
i = i + 1
Wend

End Sub

お礼

ありがとうございます。いただいた情報を参考にして再度マクロを見直してみます。

回答No.2

nobu_suzuki1

ちょっと回りくどいやり方になってしまいましたが以下のやり方でどうでしょう。

Private Sub CommandButton1_Click()
Dim Data() As String
Dim i, j As Long
Dim count As Long
Dim flag() As Boolean

i = 4

'セルAとセルDを結合して配列に格納
While Cells(i, 4) <> ""
ReDim Preserve Data(i - 4)
Data(i - 4) = Cells(i, 1) & Cells(i, 4)
i = i + 1
Wend

ReDim flag(UBound(Data))

'重複を調べるフラグ用配列を初期化
For i = 0 To UBound(Data)
flag(i) = True
Next

'重複するデータの場合flag配列にFalseを代入
For i = 0 To UBound(Data) - 1
For j = i + 1 To UBound(Data)
If Data(i) = Data(j) Then flag(j) = False
Next
Next

'フラグ配列のTrueの個数をカウントする
cnt = 0
For i = 0 To UBound(flag)
If flag(i) = True Then cnt = cnt + 1
Next

MsgBox cnt

End Sub

お礼

貴重なご意見ありがとうございました。

回答No.1

keithin

時折使う作成例：
sub macro1()
　dim myDic, myKey
　dim h as range
　dim buf as string
　dim i as long

　set mydic = createobject("Scripting.Dictionary")
　on error resume next

　for each h in range("A4:A" & range("A65536").end(xlup).row)
　if h <> "" then
　　buf = h & "_" & h.offset(0, 3)
　　mydic.add buf, buf
　end if
　next
　msgbox mydic.count

’以下オマケ
　mykey = mydic.keys
　for i = 0 to mydic.count
　cells(i + 4, "F").resize(1, 2) = split(mykey(i), "_")
　next i

　set mydic = nothing
end sub

＃ネットで「Excel VBA Dictionary」といったキーワードで検索してみると，解説サイトが多数ヒットします。

お礼

ありがとうございます。参考にさせていただきます。