VBAで各項目に合致する番号を全て抜き出したい(かつハイフンでまとめたい)

Question

VBA初心者です。
自分なりに色々考えてみたり職場の人に相談してみたのですがどうしても解決することができなかったため、こちらで相談させていただきます。

条件①と条件②の各項目に番号が付与されているので、各項目に合致した番号を全て抜き出したいです。(添付画像参照)
またこの時に、連続する番号はハイフンでつなげる。番号が飛び飛びな場合は間に「、」や「　」を入れて繋げる。ということも実現したいです・・・。

数値をハイフンでまとめる方法は下記の方法で実現できそうな気がするのですが、番号をうまく抜き出すことができずお手上げ状態です。 
VBAでカンマ区切り数値をハイフンでまとめたい
https://oshiete.goo.ne.jp/qa/8299917.html

説明が拙く申し訳ありません。どなたかお知恵を貸していただけますと幸いです。

fujillin · Accepted Answer

こんばんはセル位置もわからないし、内容もよくわかりませんけれど、勝手に想像をたくましゅうして、こんなことでしょうか？ ※ 添付図のF列の書式は文字列にしておかないと、「1-2」などの値が日付として解釈されてしまいますのでご注意。 Sub Sample_12225223() Dim dic As Object, outRng As Range Dim maxRw As Long, rw As Long, col As Long Dim keys(), k, s As String Set dic = CreateObject("Scripting.Dictionary") Set outRng = Range("E1") maxRw = Cells(Rows.Count, 1).End(xlUp).Row For col = 2 To 3 dic.RemoveAll rw = 2 While rw <= maxRw k = Cells(rw, col).Value s = Cells(rw, 1).Value For rw = rw + 1 To maxRw If Cells(rw, col).Value <> k Then Exit For Next rw If s <> Cells(rw - 1, 1).Value Then s = s & "-" & Cells(rw - 1, 1).Value If dic.exists(k) Then dic(k) = dic(k) & "," & s Else dic.Add k, s Wend outRng.Value = Cells(1, col).Value keys = dic.keys For Each k In keys Set outRng = outRng.Offset(1) outRng.Value = k outRng.Offset(, 1).Value = dic(k) Next k Set outRng = outRng.Offset(2) Next col End Sub

tatsumaru77 · Answer

番号は1,2,3,4というように１からの連番で昇順に並んでますが、
番号が戻るとか、重複するとかのケースもありありますか。
ケース①　番号が10,9,8
ケース②　番号が1,2,3,10,15
ケース③　番号が1,2,3,4,3,3,4,5,6

tatsumaru77 · Answer

１．画面のレイアウトですが、添付図のように
①1行目は見出し
②A列が番号
③B列が項目名
④H列へ２行目から出力
でよろしいでしょうか。

２．出力時の文字ですが
：は、全角のコロン
-は、半角のハイフン
、は全角のカンマ
で間違いないでしょうか。

めぐみん_ · Answer

補足に対して。

上級者なんてとんでもありません。
そうであれば最初の回答でコードが作れてました。
提示されてるベテラン様のコードはその動きとしては頭にモヤモヤ浮かんでましたが、具体的に作成も出来なかったですし。
私は永遠の初級者です。

上級者様って私が今まで回答してきた物とは比べ物にもならないコードを書かれますよ。
２０年前に思い知りました。（当時は無論ちんぷんかんぷんでした）

Qchan1962 · Answer

こんばんは、
取り敢えず、べたアルゴリズムが先に浮かんだので少し違うと思いますが、
（条件名が繰り返し出て来ますが、直せると思います）こんな感じかな？
番号はA列です。条件②も同じかな？
DictionaryのItemでもう少しわかり易く出来ると思います。

Sub Sample()
Dim i As Long, j As Long, n As Long
Dim Ary, tmp As String
Dim flag As Boolean
Dim Dic, msg
    Set Dic = CreateObject("Scripting.Dictionary")
    With ActiveSheet
        For i = 1 To Cells(Rows.Count, "B").End(xlUp).Row
            If Not Dic.Exists(Cells(i, "B").Value) Then
                Dic.Add Cells(i, "B").Value, Cells(i, "B").Value
            End If
        Next i
        Ary = Dic.Keys
        For i = 0 To UBound(Ary)
            flag = False
            For j = 1 To .Cells(Rows.Count, "B").End(xlUp).Row + 1
                If Ary(i) = .Cells(j, "B").Value Then
                    If flag = False Then
                        tmp = Ary(i) & " :" & .Cells(j, "B").Offset(, -1).Value
                    End If
                    flag = True
                Else
                    If flag = True Then
                    n = n + 1
                        msg = msg & tmp & "-" & .Cells(j - 1, "B").Offset(, -1).Value & vbCrLf
'                        .Cells(n, "G") = tmp & "-" & .Cells(j - 1, "B").Offset(, -1).Value
                        tmp = ""
                        flag = False
                    End If
                End If
            Next
        Next
    End With
    MsgBox (msg)
End Sub

出来れば同じシートに出力
コメントアウトを解除してください。（G列に出力）

めぐみん_ · Answer

結果の方のアルファベット（条件①、②の値）って背景色も必要なのでしょうか？
それともただ質問用の仕様なのでしょうか？

ArrayList とかが使えるのなら初級者でもいけそうなのですが、最近のWIN10だと『.NET Framework 3.5 の有効化』が上手くいかないみたいですしね。
こちらで出来ても質問者さんの方でダメなら意味ないですし。

昭和ジジィのせいなのか画像とリンク先の内容で『なさりたい事』はわかるのですが、それを『現実に可能とさせる方法』で頭のお味噌が発酵中です。

tatsumaru77 · Answer

すみません。なにをなさりたいのか上記の画像だけではよくわかりません。
もっと、具体的に例を挙げて説明していただけませんでしょうか。

VBAで各項目に合致する番号を全て抜き出したい(かつハイフンでまとめたい)

こんばんは

番号は1,2,3,4というように１からの連番で昇順に並んでますが、

１．画面のレイアウトですが、添付図のように

補足に対して。

こんばんは、

結果の方のアルファベット（条件①、②の値）って背景色も必要なのでしょうか？

すみません。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング