EXCEL2000 VBA 選択範囲（1列）の重複を取り除いて右側に表示する。 実験

EXCEL2000 VBA  選択範囲（1列）の重複を取り除いて右側に表示する。　実験

Sub選択範囲列の重複データを取り除いたデータを作る()

'選択範囲の重複データを取り除いたデータを作る

'

Dim i, j As Long       '汎用

Dim d() As Variant    'セル値格納用配列

Dim k As Long        '重複の無いデータ個数

Dim x As Variant     '

Dim FL1 As Integer  '重複が有れば　FL=1 無ければ FL=0

Dim sRow As Long    '選択範囲の先頭列番号

Dim sCol As Long        '選択範囲の列番号

 

ReDim d(Selection.Rows.Count + 1)

If Selection.Columns.Count > 1 Then MsgBox "列幅は１つにしてください": Exit Sub

sRow = Selection.Row

sCol = Selection.Column

d(1) = Selection.Rows(1)

k = 1

For i = 1 To Selection.Rows.Count

    x = Selection.Rows(i).Value

    FL1 = 0

    '重複があるか判定

        For j = 1 To k

            If d(j) = x Then FL1 = 1     'd()の値と同じもが有ればFL=1

        Next j

        If FL1 <> 1 Then d(k + 1) = x: k = k + 1  '重複が無ければ値をd(+1)に代入

             'Debug.Print k, d(k)

        Next i

    'd()一覧を表示

        For i = 1 To k

            Cells(sRow + i - 1, sCol + 1) = d(i)

        Next i

 

End Sub

 

 

 

---

追記　
　一応　使えるかも？バージョン

 

Sub 選択範囲列の重複データを取り除いたデータを作る()

'選択範囲の重複データを取り除いたデータを作る

'

    Dim i, j As Long       '汎用

    Dim d() As Variant    'セル値格納用配列

    Dim k As Long        '重複の無いデータ個数

    Dim x As Variant     '

    Dim FL1 As Integer  '重複が有れば　FL=1 無ければ FL=0

    Dim sRow As Long    '選択範囲の先頭列番号

    Dim sCol As Long        '選択範囲の列番号

    Dim input_range As Range    'InputBox で入力されたRange

 

    On Error GoTo Er

 

'配列の個数設定

    ReDim d(Selection.Rows.Count + 1)

'選択列数　確認

    If Selection.Columns.Count > 1 Then MsgBox "列幅は１つにしてください": Exit Sub

'初期設定

    sRow = Selection.Row    '選択セルの先頭行番号

    sCol = Selection.Column '選択セルの列番号

    d(1) = Selection.Rows(1)    '先頭セルの値を配列（1）に代入

    k = 1                           '重複しないデータの個数初期値

'行数分だけ処理

    For i = 1 To Selection.Rows.Count

        x = Selection.Rows(i).Value

        FL1 = 0

         '重複があるか判定

            For j = 1 To k

                If d(j) = x Then FL1 = 1     'd()の値と同じもが有ればFL=1

            Next j

                If FL1 <> 1 Then d(k + 1) = x: k = k + 1  '重複が無ければ値をd(+1)に代入

             'Debug.Print k, d(k)

    Next i

    'd()一覧を表示するセルを決める

        'inputobox で入力

inB:    'ラベル

    'Inputboxでセル選択

            Set input_range = Application.InputBox("表示する先頭セルを1つ選択してください。", _

            "表示セルの選択", , , , , , 8)

 

    'd()一覧を表示

        For i = 1 To k

            input_range.Offset(i - 1, 0) = d(i)

        Next i

    '終了

    Exit Sub

Er:  'エラー処理

    'キャンセルボタンが押されたら　のつもり

        If Err.Number = 424 Then Exit Sub

    '選択セルが1つ以上

        If Err.Number = 13 Then MsgBox "選択セルは1つにしてください": GoTo inB

    'その他のエラー

    MsgBox "error　" & Err.Number

 

End Sub

 

 

 

タグ：Excel2000 VBA 重複