エクセルマクロ 重複しない値を転記

こんばんは、エクセル201を使っています。

転記について解らない事が有るので教えて頂けませんでしょうか。

画像の様に、Aセルに小数点以下、3桁の数値が有ります。

それを、B列に転記したいのですが、その時に重複したものは１つだけ転記し、しないものはそのまま転記したいと思います。

これをボタンクリックでやりたいのですが、詳しい方教えて頂けませんでしょうか。

よろしくお願いいたします。

質問者からの補足コメント

• 回答ありがとうございます。
  
  それでは、A列をB列に、C列をD列に転記してみたのですが上手く行きません。
  
  コードは単純に
  Rows(1).Insert
  Range("A1") = "ダミー"
  Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("B1"), unique:=True
  Rows(1).Delete
  
  Rows(1).Insert
  Range("A1") = "ダミー"
  Range("C:C").AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("D1"), unique:=True
  Rows(1).Delete
  
  としてみたのですが、どこがいけなかったのでしょうか、お手数ですが教えて頂けませんでしょうか
  
  よろしくお願い致します

  No.2の回答に寄せられた補足コメントです。 補足日時：2015/04/29 08:31

• 再度の回答ありがとうございます。
  
  お陰様で、ばっちり出来ました、ありがとうございます！
  
  それで、不躾なお願いで恐縮ですが、一点教えて頂けませんでしょうか。
  
  列の最終行に正体不明の文字があってそれも転記してしまうんです。
  
  それで、転記する数字の範囲を１.000~6.000のものに限定する、などと出来ますでしょうか？
  
  お手数をお掛けしますが、教えて頂けませんでしょうか。
  
  よろしくお願いいたします。

  No.3の回答に寄せられた補足コメントです。 補足日時：2015/04/29 08:47

• 訂正いたします。
  
  転記自体は上手く行っているのですが、空白（に見える）セルを転記していて、その正体が解らない為難行しています＞＜
  
  １から６の数字の値のみを転記する事って出来るでしょうか？
  
  お手数ですが教えて頂けませんでしょうか。
  
  よろしくお願いいたします。

  No.4の回答に寄せられた補足コメントです。 補足日時：2015/04/30 02:24

• こんばんは、再度の回答ありがとうございます。
  
  実行してみたのですが、D列への転記のみが上手く行ってる感じです。
  
  実は、元データは　A,C,E,G,I,K,M,O　の　８列ありまして、以前教えて頂いた程度の改変なら自分で出来たのですが、今回はそうは行かないようです。
  
  大変、恐縮ですが、教えて頂けませんでしょうか。
  
  よろしくお願いいたします。

  No.6の回答に寄せられた補足コメントです。 補足日時：2015/04/30 02:44

No.4 ベストアンサー 回答者： soixante 回答日時： 2015/04/29 09:34

横から失礼します。

・A列の非重複データをB列に、C列に非重複データをD列に展開したい
・データが、１～６のものだけを転記したい

これを踏まえてやってみました。Dictionaryオブジェクトの活用です。

■ｃ：列番。A列とC列を処理するので、Step 2 でループ
■ r : 行番。データの入っているところまで縦に下りていく。Do　Loop部分。
■Suchi : 数値。それぞれのデータを入れる変数

・おおまかな流れ
①　Dictionaryオブジェクトを設定
②　各データのうち、1以上かつ6以下かつ、Dic　に既に存在されていないものを
　　Dic に追加していく
③　全データのループが終わったら、Dic のキーを、Mykeys（配列）に格納
③　その後、Mykeys　の各要素を吐き出す

-------------------------------------------------------------------
Sub aaa()

Dim Dic As Variant
Dim r As Integer, c As Integer
Dim Suchi As Single
Dim Mykeys As Variant

For c = 1 To 3 Step 2
　Set Dic = CreateObject("Scripting.Dictionary")

　 r = 1
　　Do While Cells(r, c).Value <> ""
　　　Suchi = Cells(r, c).Value

　　　If Suchi >= 1 And Suchi <= 6 And _
　　　　　Not Dic.exists(Suchi) Then
　　　　　Dic.Add Suchi, Suchi
　　　End If
　　　 r = r + 1
　　Loop

　　Mykeys = Dic.keys

　　For r = 0 To Dic.Count - 1
　　　　 Cells(r + 1, c + 1).Value = Mykeys(r)
　　Next r

　　Set Dic = Nothing
Next c

End Sub
---------------------------------------------------

c のループ範囲とか、Suchi の条件設定など、適宜アレンジください。

この回答へのお礼

回答ありがとうございます。

目的の結果が得ることが出来ました、大変助かりました、ありがとうございます！

お礼日時：2015/04/30 02:02

No.8 回答者： soixante 回答日時： 2015/04/30 06:37

なんどもすみません、#4、7です。

補足を読み間違えました。6の方への補足だったんですね。

というわけで、#7 の回答、最後の部分は無視してください。

c のループ、3 を15に書き換えるだけでいいです。

この回答へのお礼

再回答いただきありがとうございます。

お陰様で無事転記する事が出来ました。

感謝しております。

ありがとうございました！

お礼日時：2015/04/30 08:42

No.7 回答者： soixante 回答日時： 2015/04/30 06:13

>元データは　A,C,E,G,I,K,M,O　の　８列ありまして

c のループを c=1 To 15 Step 2
とすれば良いです。

なお、D列の転記のみがうまくいってる、ということですが、B列にもいきませんかね？
わたしの手元のダミーデータでは正常でしたけどね。
なんか問題あればまた教えてください。

No.6 回答者： tom04 回答日時： 2015/04/29 19:05

No.2・3です。

＞転記する数字の範囲を１.000~6.000のものに限定する、などと・・・

というコトは「重複するレコードは無視する」という操作だけでなく
オートフィルタも必要になってきますね。
Sheet2を作業用のSheetとして使用していますので、Sheet2は使っていない状態にしておいてください。

＞これをボタンクリックでやりたいのですが・・・
なので、Sheet1にコマンドボタンを配置しているとします。

まず、標準モジュールに↓のコードをコピー＆ペーストしてください。

Sub Sample2()
Dim lastRow As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
With Worksheets("Sheet1")
.Range("D:D").ClearContents
.Rows(1).Insert
.Range("C1") = "ダミー"
.Range("C:C").AdvancedFilter Action:=xlFilterCopy, copytorange:=wS.Range("A1"), unique:=True
lastRow = wS.Cells(Rows.Count, "A").End(xlUp).Row
wS.Range("A1").AutoFilter field:=1, Criteria1:=">=1", Criteria2:="<=6", Operator:=xlAnd
Range(wS.Cells(1, "A"), wS.Cells(lastRow, "A")).SpecialCells(xlCellTypeVisible).Copy .Range("D1")
wS.AutoFilterMode = False
wS.Range("A:A").Clear
.Rows(1).Delete
End With
End Sub

そしてコマンドボタンのコードを↓にします。

Private Sub CommandButton1_Click()
Call Sample2
End Sub

こんな感じではどうでしょうか？m(_ _)m

No.5 回答者： hallo-2007 回答日時： 2015/04/29 10:48

通りがかりですが、エクセルには重複の削除　の機能があります。

操作
A列を、コピー、B列に張り付け
B列を選択して、リボン　データ　中央近くにある　重複の削除　をクリック
ウィザードに従って、B列のみ対象範囲にして
OK押せば、完了です。

マクロが必要であれば、マクロの記録でコードを取得してみてください。

No.3 回答者： tom04 回答日時： 2015/04/29 08:41

No.2です。

C列のデータを重複なしにD列に表示したい！というコトのようですね。

対象列の1行目に仮の「項目」を入れてやればOKですので、
＞Range("A1") = "ダミー"
を
＞Range("C1") = "ダミー"
としてみてください。m(_ _)m

No.2 回答者： tom04 回答日時： 2015/04/29 08:19

こんにちは！

項目行はなくて、データは1行目からあるのですね？

一例です。

Sub Sample1()
Rows(1).Insert
Range("A1") = "ダミー"
Range("A:A").AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("B1"), unique:=True
Rows(1).Delete
End Sub

※　1行目が項目行であれば
上記コードの1行だけで済みます。m(_ _)m

No.1 回答者： ExcelDevTool 回答日時： 2015/04/29 03:30

データ⇒重複の削除機能があります。