excel2003 重複削除マクロ 再質問

質問

QNo.3630625 excel2003　重複削除マクロ
回答マクロを実行した結果、うまくいかないケースがあり、再質問させて頂きました。

winxp he sp2, office2003
AB重複銘柄を削除した結果を、CDに書くマクロを教えてください。
この例では、日経３００投信　チャイナボーチーが重複しています。
AB(銘柄コードと銘柄名)は一体です。データは沢山あります。1700個。
列がずれて見にくいです。

A　　　　B　　　　　　　C　　　D
1313　ＫＯＤＥＸ２００　1313　ＫＯＤＥＸ２００
1319　日経３００投信　　1319　日経３００投信
1319　日経３００投信　　1380　秋川牧園
1380　秋川牧園　　　　　1381　アクシーズ
1381　アクシーズ　　　　1412　チャイナボーチー
1412　チャイナボーチー　1724　シンクレイヤ
1412　チャイナボーチー　1735　伊田テクノス
1412　チャイナボーチー　1753　土屋ツーバイホーム
1724　シンクレイヤ　　　1783　Ａ．Ｃホール
1735　伊田テクノス
1753　土屋ツーバイ
1783　Ａ．Ｃホール

回答：
1行目は項目名と判断されてしまいますので提示の例ではうまく行きましたが、正しくありません。
では、マクロ作業上でダミーで先頭に1行追加し、項目を振り、終了後にダミー行を削除するように変えてみました。
逐条で解説もつけておきます。

Sub test03()
Dim x As Long 'xは長整数と宣言
With ActiveSheet 'アクティブなシートで
.Rows("1").Insert Shift:=xlDown 'ダミー行挿入
.Range("A1") = "Code" 'ダミー項目１
.Range("B1") = "Name" 'ダミー項目２
x = .Cells(.Rows.Count, 1).End(xlUp).Row '最終行取得
.Range("A1:B" & x).Select '範囲選択
Selection.AdvancedFilter Action:=xlFilterInPlace, Unique:=True '重複を表示しない
Selection.Copy .Range("C1") 'コピーしてC1以降に貼り付け
.ShowAllData 'すべてを表示 --------------------------------------ここでデバッグエラーが発生します。
.Rows("1").Delete Shift:=xlUp 'ダミー行削除
End With
End Sub

エラーが発生するケースまでは、特定していません。
よろしくお願いします。

回答No.4

n-jun · ベストアンサー

Sub　try()
　　Dim　Dic　As　Object
　　Dim　vv,　v,　x
　　Dim　i　As　Long,　j　As　Long,　k　As　Long

　　Set　Dic　=　CreateObject("Scripting.Dictionary")

　　With　ActiveSheet
　　　　　　　vv　=　.Range(.[A1],　.Cells(Rows.Count,　1).End(xlUp).Resize(,　2)).Value

　　　　　　　ReDim　v(1　To　2,　1　To　UBound(vv,　1))
　　　　　　　ReDim　x(1　To　2,　1　To　UBound(vv,　1))

　　　　　　　For　k　=　1　To　UBound(vv,　1)
　　　　　　　　　　　If　Len(Trim(vv(k,　1)))　<　5　Then
　　　　　　　　　　　　　　i　=　i　+　1
　　　　　　　　　　　　　　v(1,　i)　=　vv(k,　1)
　　　　　　　　　　　　　　v(2,　i)　=　vv(k,　2)

　　　　　　　　　　　　　　If　Not　Dic.exists(vv(k,　1))　Then
　　　　　　　　　　　　　　　　　Dic(vv(k,　1))　=　Empty
　　　　　　　　　　　　　　　　　j　=　j　+　1
　　　　　　　　　　　　　　　　　x(1,　j)　=　vv(k,　1)
　　　　　　　　　　　　　　　　　x(2,　j)　=　vv(k,　2)
　　　　　　　　　　　　　　End　If
　　　　　　　　　　　End　If
　　　　　　　Next
　　　　　　　ReDim　Preserve　v(1　To　2,　1　To　i)
　　　　　　　ReDim　Preserve　x(1　To　2,　1　To　j)
　　　　　　　.Cells.ClearContents
　　　　　　　.Range("A1").Resize(i,　2).Value　=　Application.Transpose(v)
　　　　　　　.Range("C1").Resize(j,　2).Value　=　Application.Transpose(x)
　　End　With
　Set　Dic　=　Nothing
　Erase　v
　Erase　x
End　Sub
こうゆう感じの事でしょうか？

お礼

1705個のデータで確認しました。希望通りの結果が得られました。
親切な対応　ありがとう御座いました。

回答No.5

merlionXX

> エラーが発生するケースまでは、特定していません。

重複データがないばあいだと思います。
これでどうでしょう？
銘柄コードが10000以上も削除しています。

Sub test04()
Dim x As Long, y As Long 'xyは長整数と宣言
With ActiveSheet 'アクティブなシートで
.Rows("1").Insert Shift:=xlDown 'ダミー行挿入
.Range("A1") = "Code" 'ダミー項目１
.Range("B1") = "Name" 'ダミー項目２
x = .Cells(.Rows.Count, "A").End(xlUp).Row 'A列最終行取得
.Range("A1:B" & x).Select '範囲選択
Selection.AdvancedFilter Action:=xlFilterInPlace, Unique:=True '重複を表示しない
Selection.Copy .Range("C1") 'コピーしてC1以降に貼り付け
On Error Resume Next 'エラーをスキップ
.ShowAllData 'すべてを表示
On Error GoTo 0 'エラースキップを終了
y = .Cells(.Rows.Count, "C").End(xlUp).Row 'C列最終行取得
.Range("C1:D" & y).Select '範囲選択
Selection.AutoFilter Field:=1, Criteria1:=">=10000"
Selection.ClearContents
.Rows("1").Delete Shift:=xlUp 'ダミー行削除
End With
End Sub

補足

その通りでした。1705個*20ケースでokを確認しました。
親切な対応　ありがとう御座いました。

回答No.3

n-jun

>ABに5桁（10000以上）の銘柄があります。この銘柄がある行を削除したいのです。
ＡＢ列ですか？Ａ列のコードの事ですか？
行削除とは、Ｃ・Ｄ列にデータがあってもその行は削除？
それとも、Ｃ・Ｄ列に５桁のデータを転記しないと言う事ですか？

補足

ありがとう御座います。
A　　　B
25935　伊藤園第１種優先株式
5桁コードがある行を削除したいのです。Ｃ・Ｄ列に５桁のデータを転記しないと言う事です。
詳細：
まず最初に、5桁のある行を削除します。それから、このマクロを起動したいのです。特殊な銘柄を最初に削除したいのです。

よろしくお願いします。

回答No.2

n-jun

ANo.1です。
>ここでデバッグエラーが発生します。
このエラーが参照先の
　　実行時エラー'1004':
　　WorkSheetクラスのShowAllDataメソッドが失敗しました。
と同じではないのでしょうか？

お礼

下記を入力し、もう一度やってみました。その結果okになりました。ありがとう御座いました。
If ActiveSheet.FilterMode Then _
ActiveSheet.ShowAllData

すみませんが、追加質問の件　お願いします。

補足

その通りです。1行目に下記表示が出ています。
A　　　B　　　C　　D
Code　Name　Code　Name

回答No.1

n-jun

ShowAllDataのエラーを回避したい
http://oshiete1.goo.ne.jp/kotaeru.php3?q=1619973
こちらかな？

補足

ありがとう御座います。
私の場合、Buttonが無いので
.ShowAllData →
If ActiveSheet.FilterMode Then _
ActiveSheet.ShowAllData
置き換えてみましたが、NGでした。やり方がまずいのでしょうか

Q:追加質問させてください。
ABに5桁（10000以上）の銘柄があります。この銘柄がある行を削除したいのです。
よろしくお願いします。