Excel (VBA)

Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(Windows 10 Home : Excel 2016)
B列範囲に重複があれば、配列に行番号を格納していく方法
投稿日時: 19/12/27 09:17:23
投稿者: torao

いつもお世話になっております。
 
質問は
「重複した値のある行番号を配列に格納する」です
 
処理概要は
 
For〜Nextで
・セル範囲のi値に対し
・セル範囲のy値に一致したら配列に格納する
 (割愛していますが、配列に対して別処理があります)
・処理後、次のi値に移る
とった処理を考えております。
 
問題となっているのは
 
以下のコードの「配列格納」部分で
 
 ReDim Preserve v(1 To x)
v(x) = .Cells(y, 2).Row
 x = x + 1
 
 
重複行番号のみ格納はできているのですが
ループ分?空白要素が追加されてしまいます。
 
皆様何卒アドバイスのほどお願いいたします。
 
 
Sub chk()
    Dim sh1 As Worksheet: Set sh1 = Worksheets("利用履歴")
    Dim i As Long, x As Long, y As Long
    Dim v()
    With sh1
        '▼可視セル範囲特定
        Dim rTop As Long, rEnd As Long
        With .AutoFilter.range '先頭行
            rTop = .Resize(.Rows.Count - 1).Offset(1).Columns(1).SpecialCells(xlCellTypeVisible).Cells(1).Row
        End With
        rEnd = .Cells(Rows.Count, 1).End(xlUp).Row '最終行
        '▼重複を配列に格納
        'リストを順番に
        x = 1
        For i = rTop To rEnd
            Erase v '次に移る際に配列初期化
            'リスト総当りチェック
            For y = rTop To rEnd
                'iとyが一致すれば配列に行番号格納
                If .Cells(i, 2) = .Cells(y, 2) Then
 
 
                    ReDim Preserve v(1 To x)'←空白の要素が追加されてしまう
                    v(x) = .Cells(y, 2).Row
                    x = x + 1
 
                    '▼重複リストに対し別処理
 
                    '(省略)
 
                Else '重複なしの場合処理
 
                    '(省略)
 
                End If
            Next y
        Next i
    End With
End Sub

回答
投稿日時: 19/12/27 09:57:31
投稿者: sk

引用:
rEnd = .Cells(Rows.Count, 1).End(xlUp).Row

rEnd = .Cells(.Rows.Count, 1).End(xlUp).Row
 
引用:
重複行番号のみ格納はできているのですが
ループ分?空白要素が追加されてしまいます。

引用:
x = 1
For i = rTop To rEnd
    Erase v '次に移る際に配列初期化
    'リスト総当りチェック
    For y = rTop To rEnd
        'iとyが一致すれば配列に行番号格納
        If .Cells(i, 2) = .Cells(y, 2) Then
 
 
            ReDim Preserve v(1 To x)'←空白の要素が追加されてしまう
            v(x) = .Cells(y, 2).Row
            x = x + 1

1 レベル目の For 文における最初の Erase ステートメントで
動的配列 v を解放しているのに対し、変数 x の値は
ずっと増えっ放しだからでは。

投稿日時: 19/12/27 11:57:57
投稿者: torao

 ありがとうございます。
 追加してみましたが、変わりませんでした。
 
 基本設計がおかしいのでしょうか?
 
 
            For y = rTop To rEnd
 
       Erase v '★次に移る際に配列初期化  ←追加
 
                'iとyが一致すれば配列に行番号格納
                If .Cells(i, 2) = .Cells(y, 2) Then
 
                    ReDim Preserve v(1 To x)
                    v(x) = .Cells(y, 2).Row
                    x = x + 1
  
                Else '重複なしの場合処理
                End If
            Next y
   
 
 

投稿日時: 19/12/27 12:12:31
投稿者: torao

すみません、設計に問題が有ったようです。
もう少し調整して改めて報告させていただきます。
 
しばらくお時間ください。

回答
投稿日時: 19/12/27 12:19:30
投稿者: sk

引用:
For y = rTop To rEnd
 
    Erase v '★次に移る際に配列初期化  ←追加
 
    'iとyが一致すれば配列に行番号格納
    If .Cells(i, 2) = .Cells(y, 2) Then
 
        ReDim Preserve v(1 To x)
        v(x) = .Cells(y, 2).Row
        x = x + 1
 
    Else '重複なしの場合処理
    End If
Next y

そこに Erase ステートメントを追記したら、その後の ReDim ステートメントによって
変数 x の値(ずっと増えっ放し)と同じ要素数を持つ空の配列が再定義されて、
最後の要素にしか値が格納されないという状態になりますよ。
(余計にまずいことになっている)
 
引用:
基本設計がおかしいのでしょうか?

その配列に格納されたデータを使って何をなさろうとしているのか、
何のために毎回 Erase ステートメントを呼び出しているのか
(それは本当に目的に適っているのか)が判りませんので
正直何とも言えませんが、
 
引用:
x = 1
For i = rTop To rEnd
    Erase v '次に移る際に配列初期化
    'リスト総当りチェック
    For y = rTop To rEnd

For i = rTop To rEnd
    Erase v '次に移る際に配列初期化
    x = 1
    'リスト総当りチェック
    For y = rTop To rEnd
 
----------------------------------------------------
 
2 レベル目の For 文において空の要素を作らないようにするなら、
以上のように変数 x の値もその都度初期化する必要があるでしょう。
 
引用:
すみません、設計に問題が有ったようです。
もう少し調整して改めて報告させていただきます。

お疲れ様です。

回答
投稿日時: 19/12/27 13:00:10
投稿者: mattuwan44

オートフィルターで絞り込んだ後の処理のようですが、
可視セルの先頭行と可視セルの最終行を取得されてますが、
その間は飛び飛びじゃないのですか?
そこは可視セルじゃなくても対象なんでしょうか?
あと、条件を設定した列と重複をみていく列とは別の列なのでしょうか。
重複を見つけたとしてその後どうしたいのでしょうか?
 
単にループして重複データの行番号を記録していって、そのあとその行番号を
またループして何かをするというのはループの回数をむやみに増やして効率が悪いと思うのですが。。。
状況により方法論はかわるので、全体像が分かった方が無駄なやり取りが少ないかなぁと。
単にそういう練習ならそういう方向で考えてもいいのですが。。。
いろいろ考えても結局あとで方針が変わるのがいやなので、、、、、、

投稿日時: 19/12/27 13:42:56
投稿者: torao

コメントありがとうございます。
 
 
オートフィルタの絞り込みについて
 
 
 
シート構成の部分ですが
 
(帳票形式となっております)
 
行:5000行(増減あり)
列:100列(固定)
 
(フィルタ操作については)
A列:日付・・・同月で絞り込み
B列:ID番号・・・昇順で重複したIDを「ひと塊にしています」
 
※絞り込みデータは飛び飛びではありません。
 可視セルは必ず連続したデータとなります。
※上下は非表示セルがあります。
 
(やりたいことは)
 
上セルから順番にIDを見ていき
IDが重複していたら行番号を配列に全て格納
 ↓
格納した行番号をキーにデータ集計
 ↓
完了(次の重複IDを探す・・・繰り返し)
 
 
イメージとしては以下になります。
 
001
002
003 重複
003 重複
003 重複 →3つの行番号格納→処理→配列リセット→次の重複ID番号を探す
004
005 重複
005 重複
005 重複 →上記と同じ
006
007



 
すみません後から付け足し説明でご迷惑をおかけします。
 
 
 

投稿日時: 19/12/27 15:52:27
投稿者: torao

sk さん
 
x = 1
 
の位置を替えたらバッチリ必要な値のみ格納でき解決しました。
 
もう少し検証したいと思います。

回答
投稿日時: 19/12/27 19:55:37
投稿者: mattuwan44

集計とは?
 
最終的にどんな結果を得たいのですか?
 
セル範囲が分かれば、行番号をいちいち抜き出してメモっておく必要はないと思うのですが。。。
 
つまり、エクセルの機能を使えば自作する部分は少なくて済むだろうと思っています。
そして、
配列変数を使えば速くなるとどこかで知られたかと思いますが、
VBAでループを書かなくて済むならもっと速くなる可能性があります。
(時と場合によります)

回答
投稿日時: 19/12/27 20:55:13
投稿者: mattuwan44

ぐだぐだいってても、先に進まないので、、、ちょっと考えてみました。
 

Sub test()
    Dim rngID As Range
    Dim c As Range
    Dim i As Long
    Dim j As Long
    Dim myID As New Collection

    With Worksheets("利用履歴").AutoFilter.Range
        Set rngMonth = Intersect(.Cells, .Offset(1)).SpecialCells(xlCellTypeVisible).Columns(2)
    End With
    
    For Each c In rngID.Cells
        i = myID.Count
        On Error Resume Next
        myID.Add c.Value, CStr(c.Value)
        On Error GoTo 0
        If i < myID.Count Then
            j = WorksheetFunction.CountIf(rng, c.Value)
            '同じIDのものの集計処理?
            MsgBox c.Value & "合計:" & WorksheetFunction.Sum(c.Offset(, 1).Resize(j))
        End If
    Next
End Sub

 
2列目が同じ値の物の3列目を合計するなら、こんな感じでいいかも?
セル範囲が特定できるのに、敢えて行番号だけをメモる必要が分かりません。
 
ピボットテーブルで集計してその結果を自分好みで編集したら、
開発の工数や処理速度も速くなるかも??
(やってみないとわからない部分もありますが、何事も経験?)
 
あ!動かしてみてないのでバグがあるかもです。
参考になればと書いてますので、、、、

投稿日時: 19/12/27 21:43:18
投稿者: torao

皆様すみません、今見たらコメントが・・・ありがとうございます。
 
構造を見直して下記のように変更してみたところ。
目的どおりの動作が確認できましたことご報告いたします。
 
コードが長くなってしまいました・・・
 
・検索リストを作成:IDをScripting.Dictionaryにて重複なくkeysに格納
・検索リストを順番にセルのID値と比較
・ヒットしたら次々にvに格納
・検索リストとセルのID値が不一致で(何らかの処理実行して)For抜ける
・そして次の検索リストに移る
 
Sub Test2()
    Dim sh1 As Worksheet: Set sh1 = Worksheets("利用履歴")
    Dim i As Long, x As Long, y As Long, flag1 As Long
    Dim v(), keys()
    With sh1
        '▼可視セル範囲特定
        Dim rTop As Long, rEnd As Long
        With .AutoFilter.range '先頭行
            rTop = .Resize(.Rows.Count - 1).Offset(1).Columns(1) _
                   .SpecialCells(xlCellTypeVisible).Cells(1).Row
        End With
        rEnd = .Cells(Rows.Count, 1).End(xlUp).Row '最終行
 
        '▼検索値(ID)を配列格納
        Dim Dic: Set Dic = CreateObject("Scripting.Dictionary")
        On Error Resume Next '同値=エラ→無視する
        For i = rTop To rEnd
            Dic(.Cells(i, 2).Value) = .Cells(i, 2).Value
        Next i
        keys = Dic.keys
 
        '▼検索値をシートと比較し一致した値の行番号を取得
        For x = LBound(keys) To UBound(keys)
            flag1 = 0: y = 1: Erase v 'リセット
            For i = rTop To rEnd
                If keys(x) = .Cells(i, 2).Value Then
                    ReDim Preserve v(1 To y)
                    v(y) = .Cells(i, 2).Row
                    y = y + 1: flag1 = 1
                    '▼x格納状態+セル不一致=【処理】してFor抜ける
                ElseIf flag1 = 1 And keys(x) <> .Cells(i, 2) Then
                    '【なんらかの処理】
                    Exit For
                End If
            Next i
        Next x
    End With
End Sub
 

投稿日時: 19/12/27 22:16:33
投稿者: torao

 
何を作ろうとしているのかですが
 
顧客の施設利用履歴の集計表を作成しようとしています。
 
施設利用状況を個人ごとに「利用月+顧客ID+名前+利用期間・・」と1行1レコードとして入力しています
 
例えば
Aさんが10回施設利用したらSheetに10行分追記すると行ったかたちで利用履歴が記録されます
中には1回(1行のみ)のみといった方もおられます。
 
一回の利用で1行ですので
 
Aさん 1-3日迄
Aさん 5-6日迄
Aさん 8-9日迄



と入力されていきます
 
それを1ヶ月間、利用履歴を追記していき最終的に集計表をつくるのですが・・・
 
集計表はカレンダー形式です。
個人行にあるカレンダーエリアに利用期間から算出して該当する日付に記号を付記していきます。
 
手順は
 
・フィルタで、同じIDをひと塊にした状態で
★手作業で個人範囲を選択し
・マクロ実行(完成済みの質問とは別のプログラム)
・選択範囲内の最終行に全ての期間の履歴がカレンダーに集約される
 
        日付 1 2 3 4 5 6 7 8 9 10 11 ・・・
Aさん 1-3日迄
Aさん 5-6日迄
Aさん 8-9日迄    ○ ○ ○   ○ ○   ○ ○
 
といったかたちです(変なかたちですが、これが仕様ですので・・・)
 
【今回の質問部分】
 
上記のプログラム上の流れの中で、一部を自動化したく質問した部分があります。
それは
 
★手作業で個人範囲を選択し・・・・・・・・この部分
 
の部分になります。
今まで、手作業でセル範囲を特定していましたが、なんとかできそうです。
 
 
 
 
 
 
 

回答
投稿日時: 19/12/28 11:03:10
投稿者: simple

質問者さんの作成されたマクロで機能していればそれはそれで貴重で結構だと思います。
 
こんな考え方もありますね。
今のコードですと、各人ごとに、つねに最初の行から比較を始めるのがちょっと無駄な感じ。
折角dictionaryを使うなら、重複除き機能だけでなく、開始行を値に持ったらどうでしょう。
こんな風にすると、情報が活かせるかもしれません。

    '各人の記録の開始行をdictionaryに保持
    For k = rTop To rEnd
        If Not dic.Exists(Cells(k, 2).Value) Then
            dic(Cells(k, 2).Value) = k
        End If
    Next i
    
    '各人の開始行から終了行をもとに、別途のマクロを実行
    items = dic.items
    For k = 1 To dic.Count - 1
        Debug.Print items(k - 1); items(k) - 1  '別途マクロの代替
    Next
    '最後の人に関する追い込み処理
    Debug.Print items(k - 1); rEnd              '別途マクロの代替

その他の気づき。
(1)
    On Error Resume Next '同値=エラ→無視する
    For i = rTop To rEnd
        Dic(.Cells(i, 2).Value) = .Cells(i, 2).Value
    Next i
  この書き方の場合、Errorは起きませんから、On Error Resume Nextは不要です。
    Dic.Add .Cells(i, 2).Value) , .Cells(i, 2).Value
    と言う書き方のときだけ、エラーを気にする必要があります。
   (非存在を確認してから追加とか)
  (しかも、On Error Goto 0 に戻していないので、それ以降のエラーを隠蔽してしまいます。
    できるだけ早くに、元に復帰させるくせにしておいたほうがよいと思います。)
 
(2)こうした「id等が連続している部分について何らかの処理をする」という場合には、
   以下のような書き方が使われることがあります。
 
   currentID = Cells(rTop, 2).Value
    startRow = rTop
    For k = rTop To rEnd
        id = Cells(k, 2).Value
        If id <> currentID Then     '新しいidを読み込んだら
            'startRow から (k-1)を対象に、別マクロを実行
            currentID = id          '以下はidが連続するように更新
            startRow = k
        End If
    Next
    startRowからrEndを対象に別マクロを実行 (最後のcurrentIDに対する処理)

    こうすれば、ワンパス(one-pass)での処理(= データを上から下まで一回だけ読む処理)で
    対応できます。ご参考まで。

投稿日時: 19/12/28 14:12:03
投稿者: torao

simple さん
 
丁寧にアドバイスありがとうございます。
 
ワンパス(one-pass)での処理
 
ありがたい情報です。参考に組み込んで結果をご報告いたします。

トピックに返信