VBA 配列格納 重複を拒否

Question

お疲れ様です。

配列格納時に重複チェックを行いデータ格納を行うか、行わないかの判断をしたいです。

下記エクセルのシートがあるとします。

A列,B列,C列,D列,E列,F列,G列,H列
――――――――――――――
性別,頭,鼻,耳,目,手,口,足
男A-○,○,○,○,,,○,○
男B-○,○,○,,,○,○,○
男C-○,○,○,,,○,○,○
男D-,○,○,,,○,○,○
女A-○,,,,,,○,○
女B-○,,,,,○,○,○
女C-○,,,,,○,○,○
女D-○,,,,,○,○,○

上記のデータを男、女でまとめ、それぞれ○がついているところのORをした結果のヘッダを格納したいです。
たとえば男の場合は、B列～H列では
○,○,○,,○,○,○となるので、
配列に「頭、鼻、耳、手、口、足」を男として格納し、下記になるよう格納

Dim Hoge(1,7) As String
Hoge(0,0) = "男"
Hoge(0,1) = "頭"
Hoge(0,2) = "鼻"
Hoge(0,3) = "耳"
Hoge(0,4) = "手"
Hoge(0,5) = "口"
Hoge(0,6) = "足"
Hoge(0,7) = ""

女性の場合は

Hoge(1,0) = "女"
Hoge(1,1) = "頭"
Hoge(1,2) = "手"
Hoge(1,3) = "口"
Hoge(1,4) = "足"
Hoge(1,5) = ""
Hoge(1,6) = ""
Hoge(1,7) = ""

となるように格納します。

この時の条件として、下記のような実装をしているのですが、
コメントに記載されているような、重複データが格納されてしまうので、どのように回避すべきか悩んでおります。

Dim i As Integer
Dim j As Integer
For i = 1 To 8
  For J = 1 To 8
    If Cells(i + 1,j + 1) = "○" Then
       '配列格納処理を入れたいが、上の条件文だと、○が男A、男Bで被った場合、”頭”が二つ格納されてしまう。
    End If
  NEXT
NEXT
If Cells()

よろしくお願いいたします。

Answer 1

重複チェックは Dictionary を使うと簡単です。
頑張ってください。

Answer 2

簡単な方法

この処理で作成した配列をその後どう使いたいかによっても変わってきそうですが、一番お手軽な方法はakabeeさんから提示されているような、配列を上書きしていく方法だと思います。

ただし、この方法では配列Hogeの要素２のインデックスに対し、設定される項目内容が固定となります。
つまり
Hoge(n, 0) :性別
Hoge(n, 1) :頭
Hoge(n, 2) :鼻
Hoge(n, 3) :耳
Hoge(n, 4) :目
Hoge(1, 5) :手
Hoge(1, 6) :口
Hoge(1, 7) :足
となります。

例えば例文の女性の場合だと、
Hoge(1,0) = "女"
Hoge(1,1) = "頭"
Hoge(1,2) = ""
Hoge(1,3) = ""
Hoge(1,4) = ""
Hoge(1,5) = "手"
Hoge(1,6) = "口"
Hoge(1,7) = "足"
というように○のない項目は間が飛ぶような結果になりますので、配列から取り出す時には値の入っているものだけ取り出すような配慮が必要です。

別案

「私ならどう書くか」という観点からの別案として、ワークシート関数COUNTIFSを利用する方法をご紹介します。

範囲全体に対して、COUNTIFSで性別と各列で○がついている行数を判断し、配列に格納します。

COUNTIFSは条件に一致するセルの数を返してくれる関数です。

１つ目の条件として、対象範囲("A2:H9")のA列から、"男"（または"女"）から始まるセルを判定しています。
２つ目の条件は列ループにより変動していきますが、対象範囲のB列以降を順番に処理していき、各列毎に値が"○"のセルを判定しています。

これら２つの条件を両方満たす行の数が返されることになるので、1行でも見つかればその性別で○のついている項目ということになりますので見出し文字列を配列に格納する、という流れになっています。

この方法であれば、行単位ではループせず、列ごとに合計行数で判別を行うため、重複を考慮する必要がありません。

Sub Sample()
    Dim Hoge(1, 8) As String
    
    Dim iIdx1 As Integer
    Dim iIdx2 As Integer
    Dim iCol As Integer
    
    Dim rng As Range
    Set rng = Range("A2:H9")    '対象範囲
    
    'あらかじめ性別を格納
    Hoge(0, 0) = "男"
    Hoge(1, 0) = "女"
    
    For iIdx1 = 0 To 1  '要素１（性別）をループ
        iIdx2 = 1   '要素２のカウンタを初期化
        For iCol = 2 To 8
            'COUNTIFSでA列の性別と、対象列が○の行数をカウント。１行でも見つかれば見出し内容を配列に格納
            If Application.WorksheetFunction.CountIfs(rng.Columns(1), Hoge(iIdx1, 0) & "*", rng.Columns(iCol), "○") > 0 Then
                Hoge(iIdx1, iIdx2) = Cells(1, iCol)
                iIdx2 = iIdx2 + 1   '要素２をカウントアップ
            End If
        Next
    Next
End Sub

以上、参考になれば幸いです。

Comments

[King_of_Flies]

実データとフォーマットがまるきっり変更になったため、大分カスタマイズで手間取りましたが、
jawaさんのソースを参考に上手く動作するものが作れました。

ありがとう。

Answer 3

ループの順番を逆にしたら楽だと思います。
現状だと、男Aについて頭・鼻～、の順で見ていますが、
頭について、男A・男B～で見ると良いです。

Dim r As Integer ' 行カウンタ
Dim c As Integer ' 列カウンタ
Dim h(2) As Integer ' Hoge用カウンタ
Dim Hoge(1, 7) As String

' 要素0には男・女をあらかじめ入れておく
Hoge(0, 0) = "男"
Hoge(1, 0) = "女"

' Hoge用のカウンタを初期化
h(0) = 1
h(1) = 1

' 横方向のループ
For c = 1 To 8
    ' 男ループ
    For r = 2 To 5
        If Cells(r, c) = "○" Then
            ' 配列に追加して
            Hoge(0, h(0)) = Cells(1, c)
            ' カウンタをインクリメント
            h(0) = h(0) + 1
            ' ループは抜ける
            Exit For
        End If
    Next
    ' 女ループ
    For r = 6 To 9
        If Cells(r, c) = "○" Then
            Hoge(1, h(1)) = Cells(1, c)
            h(1) = h(1) + 1
            Exit For
        End If
    Next
Next

男女の処理をひとつにまとめようかと思いましたが、複雑になりそうだったので分けました。

Answer 4

色々と方法はありそうですが、格納する場所が決まっているのであれば、配列にデータを「追加する」のではなく「上書きする」のではどうでしょうか。

以下のようにしてはいかがでしょう。（デバッグしていませんのであくまで参考にお願いします。）

Dim i As Integer
Dim j As Integer
Dim Hoge(1,7) As String
For i = 1 To 8
  For J = 1 To 8
    If Cells(i + 1,j + 1) = "○" Then
       '配列の列番号の位置に、１行目の列の値を格納
　　　　'こうすれば値が重複することは無い
       Hoge(j) = Cells(1,j + 1)
    End If
  NEXT
NEXT
If Cells()

男女のデータ格納を分ける場合は格納時の直前に条件分岐等を入れれば良いかと思います。