【VBA】指定の列に含まれる文字列を行ごとに結合したい

Question

前提・実現したいこと

初めて質問致します。

1行目に番号が振られていて、同じ番号の列の内容を行ごとに結合したいと考えています。
実際のものはデータが多い為、なるべく速く完了する方法はありませんでしょうか。

処理後のイメージは次のようにコロン等の記号を挟み、余分な列は削除された形です。
重たくなるようなら記号を挟まず結合でも構いません。元のデータでA2,B2セルやE2,F2のように値が同じ場合は重複せず出力したいです。

試したこと・発生している問題

行と列がそれぞれ数千ずつあり、次のような方法で試してみたのですが一向に処理が終わりません。中断後にシートを見たところ処理自体は進んでいるようでした。

1. 値が重複しているセルの入力値を削除

　・例えば1行目が"1"の列について
最初の列Aと2番目の列Bの値を各行繰り返し処理で比較。同じ値のセルがあればB列の該当セルをUnionメソッドで連結する。3番目C列以降の列も同様にA列と比較し連結。
・Unionメソッドに入れたセルの入力値をまとめてClear
_
0. 1行目の値が同じセルの値を結合
・TextJoin 関数で"1"の列(A:C)の文字列を各行ごとに結合
・最終行まで繰り返し
_
0. 1行目が"1"の列2番目以降の列は必要無いのでDelete
_
0. 1行目が"2"以降も、同じ番号の列が複数あれば繰り返す

最初、列をそれぞれ配列に格納し、要素が同じもの同士の値を連結できるような方法があればと思い調べましたが、配列内の全要素の連結しか見つからず… 初学者なので知識が足りていないかもしれませんが、どなたかお答え頂ければ幸いです。

※追記：1行目の番号は1からの連番です。出力先は別シートでも構いません。
"行と列がそれぞれ数千ずつ"と書きましたが、列は別の処理により減っているので、正しくは列が100、行が8000程度になります。
※追記2:セル内のデータですが、空白の場合もあります。

Comments

[tatsu99]

1行目の番号は必ず１からの連番になってますか。番号が飛ぶことはありますか。
出力先は別のシートの方が良いかと思いますが、同じシートに結合した結果を出力するのでしょうか。

[nana_mag]

1からの連番です。同一番号がいくつあるかは番号により異なりますが。
同一シートで考えておりましたが、別シートでも構いません。
また"行と列がそれぞれ数千ずつ"と書いてしまいましたが、列は別の処理により百程度まで減った状態でした。

[tatsu99]

1行目に3 3 2 2 1 1
2行目にA B C D E F
とあった場合、
2行目をまとめた結果は
E:F C:D A:B ですか（番号順出力）、それとも
A:B C:D E:F ですか（元の並びの順に出力）

[nana_mag]

データは1から昇順ですが、もしその場合は1行目が3 2 1、2行目がA:B C:D E:Fの想定です。

Answer 1

以下のようにしてください。
こちらの環境で、10000行、150列のデータで約2分30秒かかりました。(corei5 メモリ12G)
Sheet1の内容を読み込み、Sheet2へ出力します。

Option Explicit
Public Sub 列統合()
    Dim dicT As Object      '番号対応の列を記憶
    Dim dicV As Object      '重複した値の削除用
    Dim rg As Range
    Dim maxrow As Long      '最大行
    Dim maxcol As Long      '最大列
    Dim wrow As Long        '行　作業用
    Dim wcol As Long        '列　作業用
    Dim vcol As Variant     '列　作業用
    Dim key As Variant      'キー
    Dim keys As Variant     'キーの一覧
    Dim val As Variant      '値
    Dim vals As Variant     '値の一覧
    Dim sh1 As Worksheet    'データのシート
    Dim sh2 As Worksheet    '出力先シート
    Dim arr As Object       '列のArrayList
    Dim stime As Variant    '開始時刻
    Dim etime As Variant    '終了時刻
    Application.ScreenUpdating = False
    stime = Time
    Set dicT = CreateObject("Scripting.Dictionary")    ' 連想配列の定義
    Set dicV = CreateObject("Scripting.Dictionary")    ' 連想配列の定義
    Set sh1 = Worksheets("Sheet1")
    Set sh2 = Worksheets("Sheet2")
    Set rg = sh1.Range("A1").CurrentRegion
    maxrow = rg.Rows.Count
    maxcol = rg.Columns.Count
    '番号を取得し、番号対応の列を記憶する
    For wcol = 1 To maxcol
        key = sh1.Cells(1, wcol).Value
        If key = "" Then
            MsgBox ("番号が空です")
            Exit Sub
        End If
        If dicT.Exists(key) = False Then
            '新規番号なら、空のArrayListを作成する
            Set arr = CreateObject("System.Collections.ArrayList")            '.NET Frameworkへの参照
            dicT.Add key, arr
        End If
        '番号対応の列を追加する
        dicT(key).Add wcol
    Next
    'Sheet2クリア＆1行目作成
    sh2.Cells.ClearContents
    keys = dicT.keys
    wcol = 1
    For Each key In keys
        sh2.Cells(1, wcol).Value = key
        wcol = wcol + 1
    Next
    'Sheet1を2行から最終行まで繰り返す
    For wrow = 2 To maxrow
        '番号=1～最大番号迄繰り返す
        keys = dicT.keys
        wcol = 1
        For Each key In keys
            dicV.RemoveAll
            '番号に対応する列の一覧を取得
            Set arr = dicT(key)
            '各列の重複削除及び空でない要素の登録
            For Each vcol In arr
                val = sh1.Cells(wrow, vcol).Value
                If val <> "" Then
                    dicV(val) = True
                End If
            Next
            '空でないなら、:で区切りSheet2へ出力
            If dicV.Count > 0 Then
                vals = dicV.keys
                sh2.Cells(wrow, wcol).Value = Join(vals, ":")
            End If
            wcol = wcol + 1
        Next
    Next
    etime = Time
    Application.ScreenUpdating = True
    MsgBox ("実行時間(時:分:秒)=" & Hour(etime - stime) & ":" & Minute(etime - stime) & ":" & Second(etime - stime))
End Sub

Comments

[nana_mag]

ありがとうございます！回してみます。

[nana_mag]

動きました、ありがとうございます。空白セルがそれなりにあった為か1分も掛かりませんでした。
丁寧にコメントを付けて頂いていて非常に分かりやすかったです。また何かありましたら宜しくお願い致します。

Answer 2

**「実際のものはデータが多い為、なるべく速く完了する方法」**ということなので、
表データを配列に格納して配列内で処理して、一気に出力する方法で考えてみました。
重複排除は、Dictionaryオブジェクトを利用しました。
そのため、参照設定で「Microsoft Scripting Runtime」にチェックを入れておく必要があります。

Option Explicit
Const sep = ":" '区切り文字

Public Sub Main()
    Dim inTbl
    inTbl = Worksheets(1).Cells(1, 1).CurrentRegion.Value

    Dim outTbl
    ReDim outTbl(1 To UBound(inTbl, 1), 1 To UBound(inTbl, 2))

    Dim c As Long, c1 As Long, c3 As Long

    c1 = 1: c3 = 1
    For c = 1 To UBound(inTbl, 2) - 1
        If inTbl(1, c) <> inTbl(1, c + 1) Then
            columnJoin inTbl, outTbl, c1, c, c3
            c1 = c + 1: c3 = c3 + 1
        End If
    Next
    columnJoin inTbl, outTbl, c1, c, c3
    
    Worksheets(2).Cells(1, 1).Resize(UBound(outTbl), UBound(outTbl, 2)).Value = outTbl
End Sub

Sub columnJoin(inTbl, outTbl, c1 As Long, c2 As Long, c3 As Long)
    Dim r As Long
    outTbl(1, c3) = inTbl(1, c1)
    For r = 2 To UBound(inTbl)
        outTbl(r, c3) = RemoveDuplicatesBlank(inTbl, r, c1, c2)
    Next
End Sub

Function RemoveDuplicatesBlank(Tbl, r As Long, c1 As Long, c2 As Long) As String
    Dim dic As New Dictionary
    Dim c As Long
    For c = c1 To c2
        If Tbl(r, c) <> "" And Not dic.Exists(Tbl(r, c)) Then dic(Tbl(r, c)) = c
    Next
    RemoveDuplicatesBlank = Join(dic.Keys, sep)
End Function

一番目のシートに表データがあり、2番目のシートに出力するコードになってます。
同じシートに上書きする場合は、Mainの最後の行のWorksheets(2)をWorksheets(1)に変更するだけです。

Comments

[nana_mag]

回答ありがとうございます。
Dictionaryオブジェクトは使ったことがないので勉強しますね。
上手く動きましたらまたコメント致します！

[nana_mag]

2点お聞きしたいのですが、RemoveDuplicatesBlank内のDim dic As New Microは、Dim dic As New Dictionaryとは異なるものなのでしょうか。
また、Dictionaryオブジェクトの値として、対応するキーの列番号と言っていいのか2次元目を取ってきていますが、これは仮に置いているもので別の値でも問題ないのでしょうか。拙い理解ですが、呼び出し元に返す値として必要なのはキーのみになっているように読めたので。

[hatena19]

Dim dic As New Dictionary が正しいです。回答の方も修正しておきます。

DictionaryのItemは重複排除の目的には必要ないので仮のものですので、ご推察の通りなんでもいいです。

[nana_mag]

PCがブラックアウトしてしまい処理出来ませんでしたが、とても綺麗な構成のコードで勉強になりました。ありがとうございます。
確認出来ていませんがメモリ不足でしょうかね...(corei5,16GB)。
かなり勉強になりましたので、またデータの少ない時に応用させて頂きたいと思っております。

Answer 3

こんな感じでしょうか。

Sub Sample()

    Dim ws As Worksheet
    Set ws = Sheets("Sheet1")
    
    Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    
    Dim r As Range, k As String
    For Each r In ws.UsedRange
        k = Join(Array(r.Row, r.Offset(1 - r.Row)))
        If Not d.Exists(k) Then d.Add k, CreateObject("Scripting.Dictionary")
        d(k)(r.Value) = 0
    Next
    
    ws.Cells.ClearContents
    Dim e, rc, i As Long, j As Long
    For Each e In d
        rc = Split(e)
        i = rc(0)
        j = rc(1)
        ws.Cells(i, j).Value = Join(d(e).Keys, ":")
    Next

End Sub

---

＜追記＞
空白セルもあるとのことなので、読み飛ばす処理を追加しました。
あわせて更なる速度向上のためセル範囲を配列化しました。

Sub sample2()

    Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    
    Dim ws As Worksheet, arr As Variant
    Set ws = Sheets("Sheet1")
    arr = ws.UsedRange.Value
    
    Dim r As Long, c As Long, k As Variant
    For r = 1 To UBound(arr, 1)
    For c = 1 To UBound(arr, 2)
        k = Join(Array(r, arr(1, c)))
        If Not d.Exists(k) Then d.Add k, CreateObject("Scripting.Dictionary")
        If arr(r, c) <> "" Then d(k)(arr(r, c)) = 0
    Next c, r
    
    ws.Cells.ClearContents
    For Each k In d
        r = Split(k)(0)
        c = Split(k)(1)
        ws.Cells(r, c).Value = Join(d(k).Keys, ":")
    Next

End Sub

---

＜再追記＞
他の方のコードを拝見し、更に修正を加えました。

Sub sample3()
    
    Dim d1, d2
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    
    Dim ws, maxrow, maxcol, arr
    Set ws = Sheets(1)
    With ws.UsedRange
        maxrow = .Rows.Count
        maxcol = .Columns.Count
        arr = .Value
    End With
    
    Dim c, k
    For c = 1 To maxcol
        k = arr(1, c)
        If Not d1.Exists(k) Then Set d1(k) = CreateObject("Scripting.Dictionary")
        d1(k).Add d1(k).Count, c
    Next
    ReDim arr2(1 To maxrow, 1 To d1.Count)
    
    Dim r
    For r = 1 To maxrow
        For Each k In d1
            d2.RemoveAll
            For Each c In d1(k).Items
                If arr(r, c) <> "" Then d2(arr(r, c)) = 0
            Next
            arr2(r, k) = Join(d2.keys, ":")
        Next
    Next
    
    Set ws = Sheets(2)
    ws.Cells.ClearContents
    ws.Cells.Resize(maxrow, d1.Count).Value = arr2

End Sub

Comments

[nana_mag]

やはりDictionaryを使うのですね。
コード読ませて頂いて、反映できたらまたコメント致しますね！

[jinoji]

参照設定をして、
Dim d1 As Dictionary, d2 As Dictionary としてあげると、
若干ですが速くなると思います。

[nana_mag]

何度も修正頂きありがとうございます。最後のものは20s程度で処理できました。
迷いましたが、一番要件に合っていた為ベストアンサーにさせて頂きます。ありがとうございました。