取得した文字列を変数に代入し認識させたい！ .RemoveDuplicates (Array(変数))

Question

判定列と入力されている列からに入力された値の列を取得し、取得した配列をJoin(judge_element, ", ")にて区切って文字列として変数に代入して、RemoveDuplicatesメソッドが動作するように認識させたいです。。。

現状：.Range("A3:G" & LastRow).RemoveDuplicates (Array(arry_num))ここの行で（型が一致しませんとエラーがでてしまいます。）

どのようにしたら型が一致するのですしょうか？

     Dim judge_result()  As Variant
     Dim j_k As Integer
     Dim arry_num As String
     
      
      judge_element = judge_elements
      
       arry_num = Join(judge_element, ", ")
      
      "arry_numの中身は”2, 4, 6”です"
     
          
    
    '重複を削除
    .Range("A3:G" & LastRow).RemoveDuplicates (Array("arry_num"))
    
Function judge_elements()
    Dim rngTable As Range       '表のセル範囲
    Dim flg As Boolean          'フラグが1個も立ってないかのチェック
    Dim vntIndex() As Variant   'フラグが立っている列番号の配列

    Set rngTable = Worksheets("Sheet2").Range("A1").CurrentRegion
    flg = GetArrayOfNumbers2(rngTable, vntIndex)
    If flg = False Then Exit Function
    
    judge_elements = vntIndex
    'rngTable.RemoveDuplicates vntIndex
End Function

Function GetArrayOfNumbers2(ByRef Rng As Range, _
                            ByRef ixResult() As Variant) As Boolean
    Dim rngFlag As Range
    Dim c As Range
    Dim i As Long

    i = Rng.Columns.Count
    ReDim ixResult(0 To i - 1)
    On Error Resume Next
    Set rngFlag = Rng.Rows(1).SpecialCells(xlCellTypeConstants)
    On Error GoTo 0
    If rngFlag Is Nothing Then Exit Function

    i = 0
    For Each c In rngFlag.Columns
       ixResult(i) = c.Column
       i = i + 1
    Next

    ReDim Preserve ixResult(0 To i - 1)
    GetArrayOfNumbers2 = True
End Function

|  | 判定 | 判定 | 判定 |  | 判定 |  |
|---|------|----------|--------|----------|------|--------|
|  | A | B | C | D | E | F |
| 1 | 1111 | りんご | 国産 | 青森 | 100 | A商店 |
| 2 | 1111 | りんご | 国産 | 青森 | 100 | B商店 |
| 3 | 1111 | りんご | 外国産 | 和歌山 | 100 | C商店 |
| 4 | 2222 | みかん | 国産 | 愛媛 | 500 | A商店 |
| 5 | 3333 | マンゴー | 国産 | 沖縄 | 50 | C商店 |
| 6 | 3333 | マンゴー | 国産 | 宮崎 | 50 | FG商店 |
| 7 | 3333 | マンゴー | 外国産 | メキシコ | 800 | D商店 ||列2|列3|
|
||||

Comments

[mattuwan]

判定という文字が列番号の上に来てますけど、
コードを動かす前にどうやって、それを指定するのですか？

単に列を選択するか、
セルにフラグを立てるか、
がいいかとは思いますが。。。

[mattuwan]

それから、そもそも、タイトル行は無いのですか？
エクセル的にはタイトル行があった方がなにかと便利かとは思います。

[mattuwan]

ぱっとみて気になったので

＞ 'Sheet2のA列の値をクリア
＞ For d_i = 3 To LastRow
＞ Worksheets("sheet2").Cells(d_i, 1) = ""
＞ Next d_i

↑そもそも値のクリアになってません。
長さ0の文字列を入れて見た目空白にしているだけです。

Worksheets(1).UsedRange.Columns(1).ClearContents

これで,
「左から1番目のシートの使っているセル範囲の1列目の値（数式も含む）のクリア」
という意味になります。（英語が苦手なので誤字があるかもしれません。）

[chanken]

ご丁寧にご指摘ありがとうございます。
うまく説明できなくて申し訳ありません。
判定という文字を　ABCDEGの任意の場所に打ち込み、ケースバイケースで処理をするのに、
６３パターンの処理をちまちま書かないで条件処理でうまくスマートに処理を行えないかということです。

今現状のボキャブラリーと引き出しではそのようにしか説明できません。
エクセルタイトルに関しましては、このような実装するにはどうすればいいかという案件をいただいているので本人がつけるかと思います。

[chanken]

力技で　
If Buf(i, 2) = Result(j, 2) _
And Buf(i, 3) = Result(j, 3) _
And Buf(i, 4) = Result(j, 4) _
And Buf(i, 6) = Result(j, 6) Then

63 パターン書いてそれに紐づくSub put_together(j, k, i, Result, Buf, Flag, d_Flag, Store_Array() As String)

'=============G列＝＝＝＝＝＝＝
Store_Array = Split(Result(j, 7), "/") '現在取得済みの商店を/区切りで配列に分割
'フラグを立てておき、
'現在取得済みの商店と一致していたらフラグを外す
Flag = True
For k = 0 To UBound(Store_Array)
If Store_Array(k) = Buf(i, 7) Then
Flag = False
End If
Next

If Flag Then 'フラグが立っていたら
Result(j, 7) = Result(j, 7) & "/" & Buf(i, 7)
End If

'=============D列＝＝＝＝＝＝＝
Store_Array = Split(Result(j, 5), "/") '現在取得済みの商店を/区切りで配列に分割

'フラグを立てておき、
'現在取得済みの商店と一致していたらフラグを外す
d_Flag = True
For k = 0 To UBound(Store_Array)
If Store_Array(k) = Buf(i, 5) Then
d_Flag = False
End If
Next

If d_Flag Then 'フラグが立っていたら
Result(j, 5) = Result(j, 5) & "/" & Buf(i, 5)
End If

を片っ端から書いていくことしかおもいつかないといったところです。。。

Answer 1

このような場合、私なら対象となる項目を連結した文字列で判定する方法を使います。

ただ単純に連結すると"A"と"BB"を連結した"ABB"と、"AB"と"B"を連結した"ABB"が一致してしまうため、項目間には区切り文字を挟みます。

その区切り文字にも注意が必要で、たとえばカンマ区切りとした場合"A"と"B,C"を連結した"A,B,C"と、"A,B"と"C"を連結した"A,B,C"の見分けがつかなくなります。
このためデータ内には含まれない区切り文字を選択する必要があります。

とはいえ、あくまでセルに入力できる文字しかデータには入ってこないはずですので、例えばタブ文字などのような制御文字を区切り文字として利用するとよいでしょう。

---

以下は「行番号を引数として渡すとその行から、1行目に"判定"が書かれている列の値をタブ区切りで連結した文字を返す」関数の例です。

'指定行の判定対象セルを連結した文字列を返す関数
Function MakeCheckKey(ByVal iRow As Integer) As String
    Dim s() As String   '対象項目配列
    Dim cnt As Integer  '配列カウンタ
    
    Dim iCol As Integer '列ループ
    cnt = 0
    
    'B列～F列をループ処理
    For iCol = 2 To 6
        If Cells(1, iCol) = "判定" Then
            '1行目が"判定"の場合
            
            '配列の要素を増やす
            ReDim Preserve s(cnt) As String
            '配列にセルの値を格納
            s(cnt) = Cells(iRow, iCol)
            '配列カウンタをインクリメント
            cnt = cnt + 1
        End If
    Next
    
    '配列の各要素をタブ区切りで連結
    MakeCheckKey = Join(s, vbTab)
    
End Sub

アクティブシートを対象としたコードになっていますので、対象シートや列の範囲など、動作環境に合う内容に修正してご利用ください。
参考になれば幸いです。

Comments

[chanken]

コメントありがとうございます。これを現状のコードと合わせてどのように扱って良いのかよくわからないです。（私の引き出し不足でそもそもコメントの内容が理解できていない？）
質問自体がうまく伝わってない可能性もあるので、お手数ですが質問訂正したのでお時間あればもう一度目を通してコメントくださると嬉しいです。
お待ちしておりますm(_ _)m

[jawa]

少し説明が足りなかったようです。申し訳ありません。

現状、改善されたいと思っているのは
```
If Buf(i, 2) = Result(j, 2) _
And Buf(i, 3) = Result(j, 3) _
And Buf(i, 4) = Result(j, 4) _
And Buf(i, 6) = Result(j, 6) Then '判定が全部一致していたら
```
このIF文ではないかと思います。
これではB,C,D,F列の組み合わせでしかチェックできないからですよね。

そこで提案したのが「項目を連結してチェックする」という方法です。

現在のチェックは、例えば３行目と４行目のチェックであれば
・B3セル＝B4セルか？
・C3セル＝C4セルか？
・D3セル＝D4セルか？
・F3セル＝F4セルか？
をそれぞれチェックし、すべて一致した場合に`put_together`関数を実行する流れに入っています。

まず考え方として、この判定部分を、
・（B3セル＋C3セル＋D3セル＋F3セルを連結した文字列）＝（B4セル＋C4セル＋D4セル＋F4セルを連結した文字列）か？
という判定に変えています。

例えば
・"1111 りんご 国産 100" = "2222 みかん 国産 200"か？
というようなイメージです。

で、このように項目を連結しているのが提供させていただいたサンプルの関数です。
※上記は便宜上スペースで区切っていますが、サンプルではこれをタブ文字で区切っています。

ですので、使い方としては
```
If MakeCheckKey(i) = MakeCheckKey(j) Then
```
というような使い方になると思います。

関数の中を見ていただくと、「1行目に"判定"という文字が入力されている列」を連結対象にしているのがわかると思います。
これがチェック対象列を動的に変更するための仕掛けです。
例えばB列とC列にしか"判定"と書かれていなければ、"1111 りんご"とか"2222 みかん"といった連結結果での比較になるのです。

こんな説明でご理解いただけるでしょうか？

わからないところなどあれば、遠慮なくご質問ください。

[chanken]

とても丁寧なコメントありがとうございます。
大枠は理解しました。

現状、改善されたいと思っているのは
```
If Buf(i, 2) = Result(j, 2) _
And Buf(i, 3) = Result(j, 3) _
And Buf(i, 4) = Result(j, 4) _
And Buf(i, 6) = Result(j, 6) Then '判定が全部一致していたら
```
このIF文ではないかと思います。
これではB,C,D,F列の組み合わせでしかチェックできないからですよね。

→　まさにそこのところです。。

以下取り違えてましたら申し訳ございませんm(_ _)m

現在のチェックは、例えば３行目と４行目のチェックであれば
・B3セル＝B4セルか？
・C3セル＝C4セルか？
・D3セル＝D4セルか？
・F3セル＝F4セルか？
ではなくて、Sheet1とSheet2(RemoveDuplicatesでひとまず重複をとっぱらった表)の表の行を比較してます。

いまローカルウインドウ見ながら何が起きてるか確認しているところです。また質問すかと思いますのでよろしくお願いします。

[jawa]

なるほど、比較はCellsではなくBuf変数とResult変数を使っていましたね。失礼しました。
コード前半の転記している部分はしっかり読んでいませんでした。

回答で提示したサンプルについても、異なるシート・セル範囲から対象を取得するような作りになっていなかったので修正が必要になりそうです。

とりあえずここで言いたかったこととしては、
「複数項目を１セルずつ比較する」のではなく
「必要な項目を連結した文字列を作成し、１回で比較する」
ということです。

---
また、上記のIF文だけでなく
`.Range("B3:G" & LastRow).RemoveDuplicates (Array(1, 2, 3, 4, 5))`
の部分も修正が必要です。
現状では「B～G列ですべての列が重複するもの」を対象に除去していますが、ここも判定列を変動させるためにArrayの中身を変更する必要がありそうです。
⇒これに関するアドバイスをmattuwanさんがしてくれていますね。

---
まず判定列番号の配列（Array）を作成し重複削除する。
その配列を判定用の文字列を作成する際にも利用して、対象列を取得する。

こんな流れが作れたらスッキリしそうです。

[jawa]

・・・もう一つ見落としている要素がありました。

"/"で区切るのは、"判定"と記載されていない列すべてなのですね。
ということはput_together関数にも手を加えないといけないのですね。

下記の処理で
```
'=============G列＝＝＝＝＝＝＝
Store_Array = Split(Result(j, 7), "/") '現在取得済みの商店を/区切りで配列に分割
'フラグを立てておき、
'現在取得済みの商店と一致していたらフラグを外す
Flag = True
For k = 0 To UBound(Store_Array)
If Store_Array(k) = Buf(i, 7) Then
Flag = False
End If
Next

If Flag Then 'フラグが立っていたら
Result(j, 7) = Result(j, 7) & "/" & Buf(i, 7)
End If
```
G列とD列の違いは列番号を７としているか５としているかだけです。

ですので、この部分だけを関数化しておけば、同じ処理を繰り返し羅列する必要はなくなると思います。

[chanken]

コメントありがとうございます。

put_together関数にも手を加えないといけないのですね。
→　お気づきありがとうございます。

提案してくださった関数に関して質問させてください。。。

まず（確認ですがこういうことですよね？？？）
「必要な項目を連結した文字列を作成し、１回で比較する」
→　（”改善前”）
f Buf(i, 2) = Result(j, 2) _
And Buf(i, 3) = Result(j, 3) _
And Buf(i, 4) = Result(j, 4) _
And Buf(i, 6) = Result(j, 6) Then

　　　　　　⇩
　　　　（”改善後”）
sheet1の判定列の結合した文字列　＝　sheet2の判定列の結合した文字列

としますと、返り値が二つになるので、sub Function （）０でなくて　Sub なにかのプロシージャー名（）
にして引数二つ持たせるような形になるのでしょうか？

まだまだ初心者で色々と質問多くて申し訳ないです。

[jawa]

対象範囲は違いますが、"判定"列の項目を連結するという意味では同じことを行いますので、関数を２回呼べばいいと思います。
つまり
```
s1Key = MakeCheckKey(Sheet1の対象範囲, i)
s2Key = MakeCheckKey(Sheet2の対象範囲, j)
If s1Key= s2Key Then
```
といった具合です。もしくは
```
If MakeCheckKey(Sheet1の対象範囲, i) = MakeCheckKey(Sheet2の対象範囲, j) Then
```
と変数を介さずそのままIF文に組み込むでもOKです。

上記例では連結する行番号だけでなく、対象セル範囲も引数として渡すようなイメージで書きました。
実際には、さらに"判定"列の配列も渡してあげる必要があるかもしれません。

[chanken]

また質問させてください！

`.Range("B3:G" & LastRow).RemoveDuplicates (Array(1, 2, 3, 4, 5))`
の部分も修正が必要です。
→　現状以下のように判定が入力されている列を配列として取得したのですが、
　　.Range("A3:G" & LastRow).RemoveDuplicates (Array("arry_num"))

ここで型が一致しないというエラーが出てしまいます。変数の値をここ(Array("arry_num"))に入れることはできないんでしょうか？

Dim arry_num As String

judge_element = judge_elements

arry_num = Join(judge_element, ", ")

""ここの段階でarry_numの中身は2, 4, 6 ですが次の文で型が一致しません”

'重複を削除
.Range("A3:G" & LastRow).RemoveDuplicates (Array("arry_num"))

'判定列の値から列番号の配列を取得
Function judge_elements()
Dim rngTable As Range '表のセル範囲
Dim flg As Boolean 'フラグが1個も立ってないかのチェック
Dim vntIndex() As Variant 'フラグが立っている列番号の配列

Set rngTable = Worksheets("Sheet2").Range("A1").CurrentRegion
flg = GetArrayOfNumbers2(rngTable, vntIndex)
If flg = False Then Exit Function

judge_elements = vntIndex
'rngTable.RemoveDuplicates vntIndex
End Function

Function GetArrayOfNumbers2(ByRef Rng As Range, _
ByRef ixResult() As Variant) As Boolean
Dim rngFlag As Range
Dim c As Range
Dim i As Long

i = Rng.Columns.Count
ReDim ixResult(0 To i - 1)
On Error Resume Next
Set rngFlag = Rng.Rows(1).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If rngFlag Is Nothing Then Exit Function

i = 0
For Each c In rngFlag.Columns
ixResult(i) = c.Column
i = i + 1
Next

ReDim Preserve ixResult(0 To i - 1)
GetArrayOfNumbers2 = True
End Function

[chanken]

解決しました。色々とありがとうございましたm(_ _)m

Answer 2

解決済ですが、一例です。

Option Explicit

Sub dupulication3()
    Dim rngOld As Range                 '元データセル範囲
    Dim rngNew As Range                 '作業結果出力セル範囲
    Dim rngFlag As Range                '判定行
    Dim rngHeader As Range              '表のタイトル行
    Dim rngDataBody As Range            '表のデータ範囲
    Dim vntKeyColNumbers() As Variant   'キーとなる列番号の配列

    '表の範囲を取得
    Set rngOld = Worksheets("Sheet1").Range("A2").CurrentRegion
    Set rngNew = Worksheets("Sheet2").Range("A1")
    rngNew.Worksheet.UsedRange.ClearContents
    rngOld.Copy rngNew
    With rngNew.CurrentRegion
        Set rngFlag = .Rows(1).Cells
        Set rngHeader = .Rows(2).Cells
        Set rngDataBody = Intersect(.Cells, .Offset(2))
    End With

    '重複するキー毎に値をまとめる
    vntKeyColNumbers = Getキー列の検索(Array("D"), rngHeader)
    Set重複を纏める Application.Range(rngHeader, rngDataBody), _
              vntKeyColNumbers, _
              WorksheetFunction.Match("F", rngHeader, 0)

    'セル範囲が変わっているので再取得
    With rngNew.CurrentRegion
        Set rngDataBody = Intersect(.Cells, .Offset(2))
    End With

    vntKeyColNumbers = Getキー列の検索(Array("判定"), rngFlag)
    Set重複を纏める Application.Range(rngHeader, rngDataBody), _
              vntKeyColNumbers, _
              WorksheetFunction.Match("D", rngHeader, 0)

    'セル範囲が変わっているので再取得
    With rngNew.CurrentRegion
        Set rngDataBody = Intersect(.Cells, .Offset(2))
    End With

    '連番の再入力
    With rngDataBody
        .Sort Cells(1)
        With .Columns(1)
            .Cells(1).Value = 1
            .DataSeries
        End With
        .EntireColumn.AutoFit
    End With
End Sub

'*************<キーワードを指定してキー列を判別する関数>*******************

Function Getキー列の検索( _
         ByRef vntKeyWord As Variant, _
         ByRef rngSearch As Range) As Variant
    Dim v As Variant
    Dim c As Range
    Dim i As Long
    Dim vv() As Variant

    ReDim vv(0 To 1000)
    For Each v In vntKeyWord
        For Each c In rngSearch
            If v = c.Value Then
                vv(i) = c.Column
                i = i + 1
            End If
        Next
    Next

    If i > 0 Then
        ReDim Preserve vv(0 To i - 1)
        Getキー列の検索 = vv
    End If
End Function


'*************<重複するキー毎に値を纏めて重複削除する関数>*****************
'
'


Function Set重複を纏める( _
         ByRef rngTable As Range, _
         ByRef vntKeyColNumbers() As Variant, _
         ByVal ixColmun As Long)
    Dim rngWork As Range
    Dim rngExtended As Range
    Dim ix As Long

    '作業列にキーワードを纏める
    Set rngWork = rngTable.Columns(rngTable.Columns.Count + 1)
    rngWork.Formula = GetConnectFormula(rngTable, vntKeyColNumbers)
    'キーワードごとにセル範囲を分ける
    With Application.Range(rngTable, rngWork)
        ix = .Columns.Count
        'データ並び替え
        .Offset(1).Sort rngWork
        '小計機能を使ってキーブレーク
        .Subtotal GroupBy:=ix, Function:=xlCount, TotalList:=ixColmun
        Set rngExtended = .CurrentRegion
    End With
    '行が増えたので表のセル範囲を再取得
    With rngExtended
        Set rngExtended = Application.Range(rngTable.Rows(2), .Rows(.Rows.Count))
    End With

    'キー毎に値を纏めて書き換える
    SetJoin rngExtended.Columns(ixColmun).SpecialCells(xlCellTypeConstants)

    '小計機能解除
    Application.Range(rngTable, rngExtended).RemoveSubtotal
    '作業列のクリア
    rngWork.ClearContents
    '重複の削除
    rngTable.RemoveDuplicates vntKeyColNumbers

End Function

'****************<値の重複を削除して値を繋ぐ>**********
Function SetJoin(ByRef Rng As Range)
    Dim c As Range
    Dim a As Range

    Set c = Worksheets("Sheet3").Range("A1")
    For Each a In Rng.Areas
        If a.Cells.Count > 1 Then
            c.CurrentRegion.ClearContents
            a.Copy c
            c.RemoveDuplicates 1
            a.Value = Join(WorksheetFunction.Transpose(c.CurrentRegion), "/")
        End If
    Next
End Function

'******************<数式を生成する関数>****************
Function GetConnectFormula(ByRef rngTable As Range, ByRef ix As Variant)
    Dim f As String
    Dim v As Variant

    f = "=CONCATENATE("

    For Each v In ix
        f = f & rngTable.Rows(1).Cells(v).Address(0, 0) & ",""/"","
    Next

    GetConnectFormula = Left(f, Len(f) - 1) & ")"
End Function

セル範囲の取得部分もメインのプロシージャから追い出して、
関数化したいところだけど、ここまでで疲れました＾＾；
解読していただいて、参考になれば幸いです＾＾；；

参考URL>>
プロパティ、メソッドの探り方 マクロ記録とＦ１のHelpを使う

Comments

[chanken]

色々とありがとうございます。
コード拝見しただけではよくわからいので、ステップインで流れを確認してみようと思います。
完成したコードの件ですが前回のアドバイスとはアプローチの掛け方は違いますが、書いてくださった配列取得の関数のおかげでやりたい実装ができましたm(_ _)m’

Answer 3

.RemoveDuplicates (Array(変数))
変数の所に配列をそのまま入れたら正常に動きました。
一応これまでの質問含めた完成コード載せておきます。

Public g_row As Long

Sub dupulication2()

Worksheets("Sheet1").Activate
Dim LastRow As Long
Dim FirstRow As Long
Dim EndRow As Long
Dim copy_last As Long
Dim 開始の行 As Long
Dim 最後の行 As Long

'ここに入力してください↓
'＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊
'開始の行の指定
開始の行 = 1
'最後の行の指定
最後の行 = 7

'＊＊＊＊＊＊＊＊＊＊＊＊＊＊＊

FirstRow = 開始の行 + 2
LastRow = 最後の行 + 2
copy_last = 最後の行 - 開始の行 + 3

g_row = Row + 1

Dim header As Variant: header = Range(Cells(1, 1), Cells(2, g_row))
Dim Buf As Variant: Buf = Range(Cells(FirstRow, 1), Cells(LastRow, g_row))
Dim result As Variant
Dim i, j, k, l, m As Long
Dim Store_Array() As String
Dim Flag As Boolean

Dim d_i As Long
Dim n As Long

n = 1
m = 1

With Sheets(2)
'Sheet2に貼り付け
.Range(.Cells(1, 1), .Cells(2, g_row)) = header
.Range(.Cells(3, 1), .Cells(copy_last, g_row)) = Buf

 Dim judge_element() As Variant
 Dim judge_result()  As Variant
 Dim j_k As Integer
 Dim arry_num As Variant
 Dim S1_ele As Long
 Dim S2_ele As Long
 
  '判定列を判断する関数呼び出して代入
  judge_element = judge_elements

      
'重複を削除
Worksheets("Sheet2").Activate
Range(Cells(3, 1), Cells(LastRow, g_row)).RemoveDuplicates (judge_element)

       
'重複削除後の最終行取得
EndRow = .Cells(3, 2).End(xlDown).Row
S1_ele = EndRow - 2
S2_ele = 最後の行 - 開始の行 + 1
'Sheet2のA列の値をクリア
 Worksheets(2).UsedRange.Columns(1).ClearContents
'Sheet2のA列のセルに連番を振る
For d_i = 3 To EndRow
    Worksheets("sheet2").Cells(d_i, 1) = n
    n = n + 1
Next d_i

'重複削除後の表取得
result = .Range(.Cells(3, 1), .Cells(EndRow, g_row))

Dim s1Key As Variant
Dim s2Key As Variant
Dim ele() As Variant
Dim rest As Integer

'空白セルの配列を取得
ele = cell_ele

For i = FirstRow To LastRow
    
    For j = 1 To S1_ele
        s1Key = MakeCheckKey1(i)
        s2Key = MakeCheckKey2(j)
        If s1Key = s2Key Then ' 判定が全部一致していたら
       
          Debug.Print s1Key
          Debug.Print s2Key
           For l = LBound(ele) To UBound(ele)
                     rest = ele(l)
                     
                     If rest = 1 Then
                     
                     Else
                        Call put_together(rest, j, k, m, result, Buf, Flag, Store_Array)
                     End If
                            
            Next l

        End If
    Next
    m = m + 1
Next

'格納した結果をSheet2へ貼り付け
 For l = LBound(ele) To UBound(ele)
    rest = ele(l)
    
    If rest = 1 Then
    Else
       .Range(.Cells(3, 1), .Cells(EndRow, rest)) = result
    End If
    
Next l
    

End With

MsgBox "END"
End Sub

Sub put_together(rest, j, k, m, result, Buf, Flag, Store_Array() As String)

If result(j, rest) = "" Then '空白セルならば長さゼロの値を配列に代入
Store_Array = Split(result(j, rest), "")

Else
  Store_Array = Split(result(j, rest), "/") '現在取得済みの商店を/区切りで配列に分割

End If
'フラグを立てておき、
'現在取得済みの商店と一致していたらフラグを外す
Flag = True
For k = 0 To UBound(Store_Array)
If Store_Array(k) = Buf(m, rest) Then
Flag = False
End If
Next

If Flag Then 'フラグが立っていたら
     If result(j, rest) = "" Or Buf(m, rest) = "" Then '空白セルがあれば空の列をタブなしで結合
        result(j, rest) = result(j, rest) & Buf(m, rest)
    Else
       result(j, rest) = result(j, rest) & "/" & Buf(m, rest) 'タブをつけて結合
    End If
End If

End Sub

Function MakeCheckKey1(ByVal iRow As Long) As String

Dim s() As String   '対象項目配列
Dim cnt As Integer  '配列カウンタ

Dim iCol As Integer '列ループ
cnt = 0

'B列?F列をループ処理
For iCol = 2 To g_row
    If Cells(1, iCol) = "判定" Then
        '1行目が"判定"の場合

        '配列の要素を増やす
        ReDim Preserve s(cnt) As String
        '配列にセルの値を格納
       s(cnt) = Worksheets("Sheet1").Cells(iRow, iCol)
        '配列カウンタをインクリメント
   cnt = cnt + 1
    End If
Next


'配列の各要素をタブ区切りで連結
MakeCheckKey1 = Join(s, vbTab)

End Function

Function MakeCheckKey2(ByVal iRow As Long) As String
Dim t() As String '対象項目配列
Dim cnt As Integer '配列カウンタ

Dim iCol As Integer '列ループ
cnt = 0

'B列?F列をループ処理
For iCol = 2 To g_row
    If Cells(1, iCol) = "判定" Then
        '1行目が"判定"の場合

        '配列の要素を増やす
        ReDim Preserve t(cnt) As String
        '配列にセルの値を格納
        t(cnt) = Worksheets("Sheet2").Cells(iRow + 2, iCol)
        '配列カウンタをインクリメント
        cnt = cnt + 1
    End If
Next



'配列の各要素をタブ区切りで連結
MakeCheckKey2 = Join(t, vbTab)

End Function

'判定列の空のセルを判断する
Function cell_ele()
Dim rngTable As Range '表のセル範囲
Dim flg As Boolean 'フラグが1個も立ってないかのチェック
Dim element() As Variant 'フラグが立っている列番号の配列

Set rngTable = Worksheets("Sheet2").Range("A1").CurrentRegion
flg = GetArrayOfNumbers(rngTable, element)
If flg = Fale Then Exit Function
    
    
     cell_ele = element

End Function

Function GetArrayOfNumbers(ByRef Rng As Range, _
ByRef ixResult() As Variant) As Boolean
Dim rngFlag As Range
Dim c As Range
Dim i As Long

i = Rng.Columns.Count
ReDim ixResult(0 To i - 1)
On Error Resume Next
Set rngFlag = Rng.Rows(1).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If rngFlag Is Nothing Then Exit Function

i = 0
For Each c In rngFlag.Columns
   ixResult(i) = c.Column
   i = i + 1
Next

ReDim Preserve ixResult(0 To i - 1)
GetArrayOfNumbers = True

End Function

'判定列の値から列番号の配列を取得
Function judge_elements()
Dim rngTable As Range '表のセル範囲
Dim flg As Boolean 'フラグが1個も立ってないかのチェック
Dim vntIndex() As Variant 'フラグが立っている列番号の配列

Set rngTable = Worksheets("Sheet2").Range("A1").CurrentRegion
flg = GetArrayOfNumbers2(rngTable, vntIndex)
If flg = False Then Exit Function

judge_elements = vntIndex

End Function

Function GetArrayOfNumbers2(ByRef Rng As Range, _
ByRef ixResult() As Variant) As Boolean
Dim rngFlag As Range
Dim c As Range
Dim i As Long

i = Rng.Columns.Count
ReDim ixResult(0 To i - 1)
On Error Resume Next
Set rngFlag = Rng.Rows(1).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If rngFlag Is Nothing Then Exit Function

i = 0
For Each c In rngFlag.Columns
   ixResult(i) = c.Column
   i = i + 1
Next

ReDim Preserve ixResult(0 To i - 1)
GetArrayOfNumbers2 = True

End Function

Function Row()
Dim rngTable As Range '表のセル範囲
Dim flg As Boolean 'フラグが1個も立ってないかのチェック
Dim vntIndex() As Variant 'フラグが立っている列番号の配列

Dim RowCnt As Long
Set rngTable = Worksheets("Sheet1").Range("B2").CurrentRegion
flg = GetArrayOfNumbers3(rngTable, vntIndex)
If flg = False Then Exit Function
Row = UBound(vntIndex) - LBound(vntIndex) + 1

End Function

Function GetArrayOfNumbers3(ByRef Rng As Range, _
ByRef ixResult() As Variant) As Boolean
Dim rngFlag As Range
Dim c As Range
Dim i As Long

i = Rng.Columns.Count
ReDim ixResult(0 To i - 1)
On Error Resume Next
Set rngFlag = Rng.Rows(2).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If rngFlag Is Nothing Then Exit Function

i = 0
For Each c In rngFlag.Columns
   ixResult(i) = c.Column
   i = i + 1
Next

ReDim Preserve ixResult(0 To i - 1)
GetArrayOfNumbers3 = True

End Function

Answer 4

う～ん。回答に書いた方がいいのかな。。。

値のクリアはエクセルが命令を持っているので、そっちを使う方が簡単なうえ、処理が速いです。
また、連番の入力も、「連続データ」の入力機能がありますので、そっちを使ってください。
僕の実験では連続データ機能を使うのが、他のどの方法よりも、（思いついた方法のなかで）最速でした。

６３パターンの処理をちまちま書かないで条件処理でうまくスマートに処理を行えないかということです。

表の1行目に何か書いてあれば、選択されたと判断するなら、

こういうことがやりたいのかな？（あんまりよくわかってないですが＾＾；）
列番号の配列が欲しければ、そういう関数を自作すればいいという話かと。。。

Sub test()
    Dim rngTable As Range       '表のセル範囲
    Dim flg As Boolean          'フラグが1個も立ってないかのチェック
    Dim vntIndex() As Variant   'フラグが立っている列番号の配列
    
    Set rngTable = Worksheets("Sheet2").Range("A1").CurrentRegion
    flg = GetArrayOfNumbers(rngTable, vntIndex)
    If flg = False Then Exit Sub
    
    rngTable.RemoveDuplicates vntIndex
End Sub

Function GetArrayOfNumbers(ByRef Rng As Range, _
                            ByRef ixResult() As Variant) As Boolean
    Dim rngFlag As Range
    Dim c As Range
    Dim i As Long
    
    i = Rng.Columns.Count
    ReDim ixResult(0 To i - 1)
    On Error Resume Next
    Set rngFlag = Rng.Rows(1).SpecialCells(xlCellTypeConstants)
    On Error GoTo 0
    If rngFlag Is Nothing Then Exit Function
    
    i = 0
    For Each c In rngFlag.Columns
       ixResult(i) = c.Column
       i = i + 1
    Next
    
    ReDim Preserve ixResult(0 To i - 1)
    GetArrayOfNumbers = True
End Function

確認してないけど、提示のデータをコピペしたら、やっぱり空白に見えて空白でないセルになってる？
空白セルはジャンプ機能で検索できるので、それで検索してみたらいいかも。

読み返してみて、

何か方法があれば知恵を貸していただけると嬉しいです。

方法論として、

1）項目Gで並び替え
2）項目Dで並び替え
3）項目Dで、キーブレークしているところに集計機能で空白行（実際には小計行）を挿入
4）項目Gのデータの塊毎に順に見て行き、Transepose関数にて1次配列の値を取得しVBAのJoin関数で「/(スラッシュ)」で繋いだ文字列を取得し、そのセル範囲に入力
5）小計機能解除
6）判定と書かれた列を右から順に並び替える
7）判定と書かれた列をキーに集計機能でキーブレーク毎に空白行（小計行）挿入
8）項目D列のデータの塊毎に順に見て行き、Transepose関数にて1次配列の値を取得しVBAのJoin関数で「/(スラッシュ)」で繋いだ文字列を取得し、そのセル範囲に入力
9)最後に重複データの削除機能で重複データ削除

という手順で、欲しい結果が得られる気がします。

並び順が変わってはいけないという事なら、
最初に通し番号を振っておき、
最後にその番号で並び替えをして、用が済んだ通し番号列を削除したらいいかと思います。

まずはその手順を確立されたら、
質問するポイントが明確になるかと思います。

Comments

[chanken]

ご返信ありがとうございます。まだおっしゃている全ての意味を理解はできていませんが、それをもとに実行してみます。色々拙いですが、お時間あればまたお答えくださると嬉しいです。

今更ですが列番号を取得する関数のコード書いてくださったんですね。誠に申し訳ないながら今気づきました。。。
ありがとうございます????

[chanken]

今回もおかげさまで解決出来ました。ありがとうございました！！！