任意のセルを別シートに抽出する方法

質問

自分で選択したセルを他のシート（ファイルは同じ）上に、選択した順に上から並べたいと考えています。関数でやろうといろいろ考えましたが上手くいかず、結局マクロが必要か～と行き詰まり皆さんのお力を借りたく掲載させていただきました。
状況を説明させていただくと、住所一覧の抽出をしたいと考えています。
A1:名前　b1:住所といった順でデータが入っていますが任意で名前を選択し、マクロボタンを押すと隣のシートに行ごとコピーされるようにし、順次、選択+クリックを行えば新しいリストが出来るというイメージでやろうと思っています。
時間のあるときでかまいませんのでご協力よろしくお願いします。

回答No.4

Wendy02 · ベストアンサー

こんにちは。

「マクロ・ボタン」を押すと書かれていましたが、このようにすれば、右クリック・メニューに入りますので、それで行のコピーをしたらいかがでしょうか？
以下は、少し手を加えるだけで、ユーザー環境に合わせられる汎用マクロです。ですから、2列のみをコピー・貼り付けではなく、行にある右端までをコピーします。

コピー・マクロは、#1 さんのを参考にさせていただきました。ロジックとして、#1 のは問題がないと思います。ですから、#1 さんのでうまくいかないとすれば、こちらもダメだと思います。(何か別の条件が含まれているかもしれません)

設定は、標準モジュールです。
使用法は、A列ならA列のコピーしたいデータを選択肢、右クリック－「行コピー」で、次のシート(Sheet2)にコピーされます。Sheet2ではない場合は、myCopyプロシージャのところの設定のShName = の右の部分を書き換えてください。

'<標準モジュール>
Sub SettingMenu()
'右クリックのメニュー
　　On Error Resume Next
　　CommandBars("Cell").Controls("myCopy").Delete
　　With CommandBars("Cell").Controls.Add _
　　　　(Type:=msoControlButton, Temporary:=True, Before:=1)
　　　.BeginGroup = True
　　　.Caption = "行コピー"
　　　.OnAction = "myCopy"
　　　.FaceId = 133
　　End With
End Sub

Sub myCopy()
'コピーマクロ
Dim ShName As String
'設定
　ShName = "Sheet2"
　If IsEmpty(Selection) Then Exit Sub
　With Sheets(ShName).Range("A65536").End(xlUp)
　If IsEmpty(.Cells) Then num = 1 Else num = .Row + 1
　End With
　Selection.Range(Cells(, 1), Cells(, 1).End(xlLeftToRight)).Copy _
　Sheets(ShName).Cells(num, 1)
End Sub
Sub MenuReset()
　'通常は、Excelを終了すれば、メニューは消えますが、途中で解除したい
　'場合に適用されます。
　CommandBars("CELL").Reset
End Sub

お礼

凄い！出来ました。バッチリです。何より自分が想像していた工程よりも楽に出来るようになったのがうれしいです。
GOOの教えてサービス初めて利用させていただきましたが、本当に助かりますね。もっと自分で考えろとか言われるかと思いビクビクしていましたが本当に感謝です。私が得意な分野でお手伝いできることがあれば今後も参加させていただきます。
いま、エクセルがおもしろい時期なのでまたお願いするときがあるかもしれませんが今後もよろしくお願いします。ありがとうございました。

回答No.3

KenKen_SP

こんにちは。KenKen_SP です。

＞選択した順に上から並べたい...

選択した順に、、というのがミソですかね。。

単純にクリック毎に該当行を他シートにコピーすればよいのでしょう
が、そうなると Worksheet_SelectionChange イベントを利用すること
になりそうです。

が、エラーなくこれを制御するのは大変ですし、これだと間髪いれず
にマクロが実行されてしまうため、間違ったセルを選択したらさらに
面倒です。

アイディアですが、、

1.　ユーザーフォームに以下のコントロールを作成

　　1）リストボックス（カラム数は2）
　　2）コマンドボタン[登録]
　　3）コマンドボタン[複写]

2.　1.のフォームをモードレスで表示
3.　シート上のセルを選択し、フォームの[登録]ボタンクリックで
　　リストボックスに次の内容を登録。

　　1）Column(0)　に ActiveCell.Row
　　2）Column(1)　に ActiveSheet.Name

4.　最後に貼り付け先を指定して、[複写]ボタンクリックで、リスト
　　ボックスからシート名と行番号を読み出してデータコピー。

こんな感じでいけると思います。ついでにユーザビリティーを考えるなら、
さらにコマンドボタンを追加して、リストボックス内の順序を変更でき
るようにしたり、リストをクリックすると該当行にジャンプしたりする
と良いかもしれません。

ご参考までに。

回答No.2

excel-jiten

このVBAはいかかでしょうか？

Sub collect_up()

Set targetSheet = Worksheets("Sheet2")
cRow = 1

For cArea = 1 To Selection.Areas.Count
For cCell = 1 To Selection.Areas(cArea).Rows.Count
For i = 1 To 2
targetSheet.Cells(cRow, i).Value = Selection.Areas(cArea) _
.Cells(cCell, i).Value
Next i
cRow = cRow + 1

Next cCell
Next cArea

End Sub

お礼

アドバイスありがとうございます。
マクロの設定をしてみたところバッチリでした！
現在マクロを起動するたびに別シートにコピーされたデータが随時上書きされていますが、
出来ればマクロを起動するたびにデータが埋まった下のセルに順次追記されるようにしたいです。
お時間のあるときで結構ですのでアドバイスよろしくお願いします。

回答No.1

masa_019

Sheet2のA,B列に追加していくとして、

Selection.Resize(, 2).Copy _
Sheets("Sheet2").Range("A65536") _
.End(xlUp).Offset(1)

とか

Sheets("Sheet2").Range("A65536") _
.End(xlUp).Offset(1).Resize(, 2).Value _
= Selection.Resize(, 2).Value

とかでどうでしょうか？

お礼

迅速に対応していただきありがとうございました。
マクロ設定していましたが私のやり方が悪いのか上手く機能できませんでした。
とにかくアドバイス頂き感謝です。