Excel VBAでピポットテーブルを作成していたらエラーがでて解決できません。

質問

こんばんは。
ExcelVBAで重複していないデータのみをSheet2に転記させたいのですが、どうしたらよいのでしょうか。
A行に重複するデータが入っいます。
A列の重複しないデータとB列に入っている名前を転記してマスタを作りたいと考えています。

A　　　　B　　　　
12345　　りんごA
12346　　みかんB
12347　　いちごC
12346　　みかんB

宜しくお願い致します。

回答No.1

yuujgmn · ベストアンサー

重複するデータ「12346 みかんB」を一つ記載するのか全く記載しないのか迷いましたが、一つ記載することで作ってみました。

(1)以下(マクロ)をモジュールに貼り付けます。
(2)データがあるシート名を「Sheet1」((1)部分),データを転記するシート名を「Sheet2」((2)部分)として作成していますので、必ず２つのシート名と(1)、(2)部分を完全に一致させてください。
(3)あとはマクロを実行してください。(ツール→マクロ→マクロ→「まとめ」を選択→実行)

Sub まとめ()
Dim i As Long, k As Long, r As Range, s As Worksheet, s1 As Worksheet
Set s = Sheets("Sheet1") '(1)
Set s1 = Sheets("Sheet2") '(2)
s.Select: s1.Cells.Clear
k = 1
For i = 1 To s.Range("A" & Rows.Count).End(xlUp).Row
If Not s.Cells(i, 1).Value = "" Then
Set r = s.Columns(1).Find(what:=s.Cells(i, 1).Value, after:=s.Cells(i, 1), lookat:=1, searchdirection:=xlPrevious)
If r.Row >= i Then
s1.Range("A" & k).Value = s.Cells(i, 1).Value
s1.Range("B" & k).Value = s.Cells(i, 2).Value
End If
End If
k = s1.Range("A" & Rows.Count).End(xlUp).Row + 1
Next
s1.Select: MsgBox "全てまとめ終わりました。"
End Sub