人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

次の動作をするExcel(エクセル)2007のVBA(マクロ)コードを教えていただきたいです。


どの列であろうと関係なくセルを選択されている場合(同じ行で複数列を選択されている場合でも)、
その選択された行すべてにおいて、
【Sheet1】から特定の列のデータをコピーして、【Sheet2】の特定の列に「値として貼り付け」するVBAコードです。



(※長くなってしまったので、具体的な「続き」を、このページ下部の「コメント」欄に書かせていただきます。
よろしくおねがいします。)

●質問者: ヘンリ
●カテゴリ:コンピュータ
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

1 ● a-kuma3
●1000ポイント ベストアンサー

こんな感じでしょうか。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 10 Then Exit Sub

to_i = 1
Worksheets("sheet2").Range("A:B").Clear
Worksheets("sheet2").Range("E:I").Clear
For Each c In Target
 Worksheets("sheet2").Cells(to_i, 1).Value = Cells(c.Row, 9)  ' I → A
 Worksheets("sheet2").Cells(to_i, 2).Value = Cells(c.Row, 10)  ' J → B
 Worksheets("sheet2").Cells(to_i, 5).Value = Cells(c.Row, 11)  ' K → E
 Worksheets("sheet2").Cells(to_i, 6).Value = Cells(c.Row, 12)  ' L → F
 Worksheets("sheet2").Cells(to_i, 7).Value = Cells(c.Row, 13)  ' M → G
 Worksheets("sheet2").Cells(to_i, 8).Value = Cells(c.Row, 14)  ' N → H
 Worksheets("sheet2").Cells(to_i, 9).Value = Cells(c.Row, 15)  ' O → I
 to_i = to_i + 1
Next
End Sub

上記のコードを、Sheet1 のマクロに貼り付けます。

?【Sheet1】のB列に全角スペースが存在するときは、半角スペースに変換して【Sheet2】貼り付けます。

この条件だけ、組み込んでいません。
Sheet1 の B列は、コピーの対象ではないので。


VBA のサンプルでは、選択されたセルの数が10個まで、という制限をつけてます。
何かしら上限を設定しておかないと、シートを全選択とかされたときに Excel が固まります。
# 実際に、やっちまいました :-)




追記です。

?【Sheet1】のB列に全角スペースが存在するときは、半角スペースに変換して【Sheet2】貼り付けます。

「Sheet1 の K列を、Sheet2 の B列に貼り付けるとき」ということであれば、こんな感じです。

...

 Worksheets("sheet2").Cells(to_i, 2).Value = FullBlank2Half(Cells(c.Row, 10))' J → B

...

Function FullBlank2Half(s as String)
 FullBlank2Half = Replace(s, " ", " ")
End Function





コメントを受けての、追記です。

ActiveXコントロールのコマンドボタン(オブジェクト名:CommandButton1)を押したら実行するようにしたいのですが、

標準モジュールを追加して、以下のコードを貼りつけ、サブルーチン Copy1To2 を ボタンのマクロに登録してください。

Public Sub Copy1To2()

Set s = Selection
If s.Count > 10 Then Exit Sub

to_i = 1
Worksheets("sheet2").Range("A:B").Clear
Worksheets("sheet2").Range("E:I").Clear

For Each c in s
 Worksheets("sheet2").Cells(to_i, 1).Value = Cells(c.Row, 9)  ' I → A
 Worksheets("sheet2").Cells(to_i, 2).Value = FullBlank2Half(Cells(c.Row, 10))  ' J → B
 Worksheets("sheet2").Cells(to_i, 5).Value = Cells(c.Row, 11)  ' K → E
 Worksheets("sheet2").Cells(to_i, 6).Value = Cells(c.Row, 12)  ' L → F
 Worksheets("sheet2").Cells(to_i, 7).Value = Cells(c.Row, 13)  ' M → G
 Worksheets("sheet2").Cells(to_i, 8).Value = Cells(c.Row, 14)  ' N → H
 Worksheets("sheet2").Cells(to_i, 9).Value = Cells(c.Row, 15)  ' O → I
 to_i = to_i + 1
Next

' シートを切り替え
Worksheets("sheet2").Activate

End Sub

Function FullBlank2Half(s as String)
 FullBlank2Half = Replace(s, " ", " ")
End Function


今後、
もしかしたら20個(20行分)選択することがあるかもしれないのですが、
20個設定でもやはりExcelは固まりますでしょうか?

上限の 10 は、適当に選んだ値で、20 や 30 程度だったら、問題ないです。
Excel 2007 から、扱える行数が桁違いに増えたので、全選択はやばいですけれど、数百レベルだったら、問題ないと思います。


ヘンリさんのコメント
a-kuma3さんへ 私のとても長い説明を読んでいただいた上で、 コードのご回答ありがとうございます。 ---------------------------------------------------------------------------- 「VBA のサンプルでは、選択されたセルの数が10個まで、という制限をつけてます。 何かしら上限を設定しておかないと、シートを全選択とかされたときに Excel が固まります。 # 実際に、やっちまいました :-)」 なるほど、Excelの処理にとても負荷がかかるのですね! 教えていただきありがとうございます。 シートを全範囲選択することはないのですが、 10個以上選択することは確かにありますので、この配慮はとてもありがたいです。 今後、 もしかしたら20個(20行分)選択することがあるかもしれないのですが、 20個設定でもやはりExcelは固まりますでしょうか? 少しぐらいは(10秒くらい)固まっても問題ありませんので。 ---------------------------------------------------------------------------- 「?【Sheet1】のB列に全角スペースが存在するときは、半角スペースに変換して【Sheet2】貼り付けます。 この条件だけ、組み込んでいません。 Sheet1 の B列は、コピーの対象ではないので。」 ↑↑ 本当に申し訳ありませんでした。 a-kuma3さんがおっしゃる通り、私の間違いです。気づきませんでした。 教えて下さりありがとうございます。 訂正させていただきますと、 ↓↓のようになります。 「?【Sheet1】のJ列に全角スペースが存在するときは、半角スペースに変換して【Sheet2】のB列に貼り付けます。 (【Sheet1】J列は全角スペースのまま編集せずに、貼り付ける【Sheet2】B列だけ半角スペースにしていただきたいです。)」 ---------------------------------------------------------------------------- また、 ActiveXコントロールのコマンドボタン(オブジェクト名:CommandButton1)を押したら実行するようにしたいのですが、 これらの変更を取り入れたコードを教えていただけないでしょうか? a-kuma3さん お忙しい中 お手数をおかけして、申し訳ありません。

ヘンリさんのコメント
すいません。 私の説明が分かりにくいところもあるかもしれませんので、 流れの補足をさせてください。 ?【Sheet1】のセルを選択(複数選択) ↓↓ ?コマンドボタンを押して実行(【Sheet1】をコピー) ↓↓ ?【Sheet2】に貼り付け このような流れになります。

a-kuma3さんのコメント
回答に、追記しました。 >> お忙しい中 お手数をおかけして、申し訳ありません。 << ぼくを含めて、回答者たちは、自分の好き勝手に回答を書き込んでいるだけなので、恐縮する必要なんかありません。 ここは、そういうサイトなのですから。 ぼくは、質問の意図を読めずに迂闊な回答をして、恐縮することがよくあるんですが <tt>:-)</tt>

ヘンリさんのコメント
a-kuma3さんへ 【ぼくを含めて、回答者たちは、自分の好き勝手に回答を書き込んでいるだけなので、 恐縮する必要なんかありません。】 ありがとうございます。 そう言っていただけると、とても助かります! 【ぼくは、質問の意図を読めずに迂闊な回答をして、恐縮することがよくあるんですが :-)】 そうなんですか! a-kuma3さんのような、私の説明の間違いまで汲み取って答えていただけるような方でもそんなことがあるだなんて、 なんだか気が軽くなりました。 ありがとうございます。

ヘンリさんのコメント
a-kuma3さんへ 新しいコードを教えて下さり、ありがとうございます。 とてもスムーズに動きました。 ただ 【標準モジュールを追加して、以下のコードを貼りつけ、サブルーチン Copy1To2 を ボタンのマクロに登録してください。】 ↑↑ これについて質問させて欲しいのですが、 設置するボタンは「ActiveX コントロール」ではなくて、 「フォーム コントロール」のボタンで合っていますでしょうか? また、 「ActiveX コントロール」のボタンでは不具合が起きるのでしょうか? いえ、 単純にこの処理ではどっちのコマンドボタンの方がいいのか気になりましたので。 ---------------------------------------------------------------------------- それから、 何度も申し訳ございません。 【Sheet2】に貼り付けたら、 Excelの画面自体【Sheet2】に移るようにお願いしたいのですが可能でしょうか? (この方が便利だと思ったので。) コードを教えていただきたいです。 よろしくお願いします。

a-kuma3さんのコメント
>> 設置するボタンは「ActiveX コントロール」ではなくて、 「フォーム コントロール」のボタンで合っていますでしょうか? また、 「ActiveX コントロール」のボタンでは不具合が起きるのでしょうか? << マクロを起動するだけなので、フォームコントロールのボタンで、十分だと思います。 自分で試したときには、フォームコントロールのボタンで試しました。 >> 【Sheet2】に貼り付けたら、 Excelの画面自体【Sheet2】に移るようにお願いしたいのですが可能でしょうか? << サブルーチンの最後に、こんなのを一行追加です。 >|vb| ... Next Worksheets("sheet2").Activate End Sub ||< 回答のコードにも、追記しました。

ヘンリさんのコメント
a-kuma3さんへ またまた私の希望を取り入れたコードを教えていただき、ありがとうございます。 【Sheet2】に移動してくれるだけで、 手動で【Sheet2】に移動しなくて済むので効率が上がり助かります。 【マクロを起動するだけなので、フォームコントロールのボタンで、十分だと思います。 自分で試したときには、フォームコントロールのボタンで試しました。】 分かりました。 アドバイスありがとうございます。 マクロを起動するときは、フォームコントロールのボタンと覚えておきます。
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ