複数シートの複数列に入力されているデータを重複なしで抽出するVBAを作りたいです。

Question

シート１　　　シート２
A列　　　　　 A列
AAA　　　　　AAA
BBB　　　　　BBB
CCC　　　　　DDD
AAA　　　　　CCC
↓
シート３
A列
AAA
BBB
CCC
DDD

上記のように複数シートに入力されているデータを別のシートに重複なしで抽出するVBAを作りたいので、お知恵を貸して頂きたいです。
VBA初心者ですので、ご迷惑をおかけするとは思いますが、よろしくお願いします。

ちなみに
単一の列を同じシートの列に抽出するVBAはネットで探して成功しました。
それが以下のコードです。

Sub リスト作成()
    Dim A As New Collection, i As Long
    On Error Resume Next
    For i = 3 To Cells(Rows.Count, 3).End(xlUp).Row
        A.Add Cells(i, 3), Cells(i, 3)
    Next i
    On Error GoTo 0
    For i = 1 To A.Count
        Cells(i + 2, 6) = A(i)
    Next i
End Sub

tatsumaru77 · Accepted Answer

以下のマクロを標準モジュールに登録してください。
Option Explicit

Dim sh3 As Worksheet
Dim dicT As Object
Dim row3 As Long

Public Sub 重複無()
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim maxrow3 As Long
    Set sh1 = Worksheets("Sheet1")
    Set sh2 = Worksheets("Sheet2")
    Set sh3 = Worksheets("Sheet3")
    Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義
    maxrow3 = sh3.Cells(Rows.Count, "B").End(xlUp).Row 'B列最終行を求める
    sh3.Range("B4:B" & maxrow3).ClearContents           'B列４行以降をクリア
    row3 = 4
    Call シート3出力(sh1)
    Call シート3出力(sh2)
    MsgBox ("完了")
End Sub

Private Sub シート3出力(ByVal ws As Worksheet)
    Dim maxrow As Long
    Dim wrow As Long
    Dim key As String
    maxrow = ws.Cells(Rows.Count, "A").End(xlUp).Row 'A列最終行を求める
    For wrow = 3 To maxrow
        key = ws.Cells(wrow, "A").Value
        If key <> "" Then
            If dicT.exists(key) = False Then
                dicT(key) = True
                sh3.Cells(row3, "B").Value = key
                row3 = row3 + 1
            End If
        End If
    Next
End Sub

めぐみん_ · Answer

質問はあくまで重複をなくすことではありますが、実際には重複に絡むデータ列が存在しているとかでは？
とまずは気になりますね。

その重複削除した際にデータを追従させる手段も悩まれてたりはしませんか？
⇒セル範囲の取得法など。

違ってたらスル～して下さいな。

tatsumaru77 · Answer

補足要求です。
１．シート１のA列のデータは、１行目から開始していますか。
それとも、１行目は見出しで、データは２行目からでしょうか。
２．シート２のA列についても、同様です。

fujillin · Answer

こんにちは

説明にはA列と書いてあって、コードでは3列目（=C列）をいじくっているように見えるけれど、本当のところは何をなさりたいのでしょうか？

＞貼り付ける場所がデータ量によって異なりませんか？
VBAなんだから、調べれば良いだけ。

なさりたいことがよくわからないので、勝手に妄想してみました。
（当たるも八卦ですが、A列を集約します）
・「指定シートが存在しない」など、エラーチェックは一切行省いてあります。

Sub Q13000652()
Dim sh As Worksheet, rg As Range
Dim rw As Long, sName
With Worksheets("Sheet3")
.Columns(1).ClearContents
Set rg = .Cells(1, 1)

For Each sName In Array("Sheet1", "Sheet2")
Set sh = Worksheets(sName)
rw = sh.Cells(Rows.Count, 1).End(xlUp).Row
rg.Resize(rw).Value = sh.Cells(1, 1).Resize(rw).Value
Set rg = rg.Offset(rw)
Next sName
.Columns(1).RemoveDuplicates (1)
End With
End Sub

KenKen_SP · Answer

dictionary 重複なし vba

で検索するとサンプル見つかると思いますよ。この用途だとCollectionよりDictionaryの方が分かりやすいです。
頑張って。

銀鱗 · Answer

＞データをコピーして貼り付ける場所がデータ量によって異なりませんか？

(´・ω・`)
1行目に挿入貼り付け…って書かなかったっけ？

銀鱗 · Answer

質問者さんは勘違いされていますね。
データ範囲もVBAで指定するんですよ。

手作業で範囲を指定するとき、何を基準にデータ範囲と判断するか。
それを明確にしてみましょう。
その判断に基づいて ”プログラムを組む” のです。

銀鱗 · Answer

自分もコピーして一覧を作ったうえで重複を削除することを薦めます。
それにそのほうが処理が速い。

データ範囲を指定して複製。
Sheet3の1行目に【挿入貼り付け】。
これをSheet1とSheet2の両方で行った後に、
Sheet3で重複削除。

・・・余談・・・

質問文は
　「これを作り直せ。オレ様の成果として使ってやるｗｗｗ」　
って内容になっていますが、それで間違いないでしょうか。

ここは自力で問題を解決できるようになるためのアドバイスを受ける場所です。
そのマクロを直す中で何が分からないのかをピンポイントで質問するようにしてみましょう。
例：
　「マクロを探してきましたが、解説がないため意味不明です。
　　どなたか解説をお願いします」
　「シートを指定する書き方が分かりません」
など。

ys1957 · Answer

各シートの情報をコピーでワークシートに移し　そのシート内でキー項目でソートして重複している項目を消せば？

複数シートの複数列に入力されているデータを重複なしで抽出するVBAを作りたいです。

以下のマクロを標準モジュールに登録してください。

質問はあくまで重複をなくすことではありますが、実際には重複に絡むデータ列が存在しているとかでは？

補足要求です。

こんにちは

dictionary 重複なし vba

＞データをコピーして貼り付ける場所がデータ量によって異なりませんか？

質問者さんは勘違いされていますね。

自分もコピーして一覧を作ったうえで重複を削除することを薦めます。

各シートの情報をコピーでワークシートに移し そのシート内でキー項目でソートして重複している項目を消せば？

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

このQ&Aを見た人はこんなQ&Aも見ています

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

このQ&Aを見た人がよく見るQ&A

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

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

各シートの情報をコピーでワークシートに移し　そのシート内でキー項目でソートして重複している項目を消せば？