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



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



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

回答の条件
  • 1人3回まで
  • 13歳以上
  • 登録:2014/10/04 20:30:11
  • 終了:2014/10/06 20:23:06

ベストアンサー

id:a-kuma3 No.1

a-kuma3回答回数4365ベストアンサー獲得回数18012014/10/05 16:15:18

ポイント1000pt

こんな感じでしょうか。

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 から、扱える行数が桁違いに増えたので、全選択はやばいですけれど、数百レベルだったら、問題ないと思います。

他5件のコメントを見る
id:a-kuma3

設置するボタンは「ActiveX コントロール」ではなくて、
「フォーム コントロール」のボタンで合っていますでしょうか?

また、
「ActiveX コントロール」のボタンでは不具合が起きるのでしょうか?

マクロを起動するだけなので、フォームコントロールのボタンで、十分だと思います。
自分で試したときには、フォームコントロールのボタンで試しました。

【Sheet2】に貼り付けたら、
Excelの画面自体【Sheet2】に移るようにお願いしたいのですが可能でしょうか?

サブルーチンの最後に、こんなのを一行追加です。

	...
Next

Worksheets("sheet2").Activate

End Sub

回答のコードにも、追記しました。

2014/10/06 06:44:24
id:egaosaiko



a-kuma3さんへ


またまた私の希望を取り入れたコードを教えていただき、ありがとうございます。
【Sheet2】に移動してくれるだけで、
手動で【Sheet2】に移動しなくて済むので効率が上がり助かります。



【マクロを起動するだけなので、フォームコントロールのボタンで、十分だと思います。
自分で試したときには、フォームコントロールのボタンで試しました。】

分かりました。
アドバイスありがとうございます。
マクロを起動するときは、フォームコントロールのボタンと覚えておきます。

2014/10/06 20:20:52
  • id:egaosaiko
    (ここまで見ていただいてありがとうございます。)


    具体的に言いますと、
    どこかの列を選択したらその行において
    以下の「7つの動作を同時にしたい」です。


    ①【Sheet1】のI列のデータをコピーして
      ↓↓
     【Sheet2】のA列に貼り付け


    ②【Sheet1】のJ列のデータをコピーして
      ↓↓
     【Sheet2】のB列に貼り付け


    ③【Sheet1】のK列のデータをコピーして
      ↓↓
     【Sheet2】のE列に貼り付け


    ④【Sheet1】のL列のデータをコピーして
      ↓↓
     【Sheet2】のF列に貼り付け


    ⑤【Sheet1】のM列のデータをコピーして
      ↓↓
     【Sheet2】のG列に貼り付け


    ⑥【Sheet1】のN列のデータをコピーして
      ↓↓
     【Sheet2】のH列に貼り付け


    ⑦【Sheet1】のO列のデータをコピーして
      ↓↓
     【Sheet2】のI列に貼り付け


    ※【Sheet1】のI列、J列、K列、L列、M列、N列、O列のデータだけをそれぞれ、
    【Sheet2】のA列、B列、E列、F列、G列、H列、I列に貼り付けていきます。




    たとえば、下記のように
    【Sheet1】にデータがあるときに、
    (I列、J列、K列、L列、M列、N列、O列は分かりやすいように【】で囲っています。)


    【Sheet1】
    ●1行目
    A1:あ
    B1:い
    C1:う
    D1:え
    E1:お
    F1:か
    G1:き
    H1:く
    【I1:け】
    【J1:こ】
    【K1:さ】
    【L1:し】
    【M1:す】
    【N1:せ】
    【O1:そ】
    P1:た


    ●2行目
    A2:ち
    B2:つ
    C2:て
    D2:と
    E2:な
    F2:に
    G2:ぬ
    H2:ね
    【I2:の】
    【J2:は】
    【K2:ひ】
    【L2:ふ】
    【M2:へ】
    【N2:ほ】
    【O2:ま】
    P2:み


    ●3行目
    A3:む
    B3:め
    C3:も
    D3:や
    E3:ゆ
    F3:よ
    G3:ら
    H3:り
    【I3:る】
    【J3:れ】
    【K3:ろ】
    【L3:わ】
    【M3:を】
    【N3:ん】
    【O3:】
    P3:



    AA1とC3を選択(複数選択)したら、1行目と3行目を選択したことになるので


    【Sheet2】
    ●1行目(【Sheet1】の1行目データ)
    A1:け
    B1:こ
    C1:
    D1:
    E1:さ
    F1:し
    G1:す
    H1:せ
    I1:そ


    ●2行目(【Sheet1】の3行目データ)
    A2:る
    B2:れ
    C2:
    D2:
    E2:ろ
    F2:わ
    G2:を
    H2:ん
    I2:


    上記のように【Sheet2】に貼り付けられます。



    また、【Sheet2】に貼り付けるときには以下の条件を満たしていただけると理想的です。
        ↓↓↓
    ①【Sheet1】でコピーしたデータはすべて、「値として」【Sheet2】に貼り付けます。
    ②【Sheet1】のB列に全角スペースが存在するときは、半角スペースに変換して【Sheet2】貼り付けます。
    ③【Sheet1】に空白セルが存在するときは、空白のまま【Sheet2】に貼り付けます。
    ④【Sheet1】で複数行選択したときは、【Sheet2】の1行目から行を飛ばさずに(何も入力しない行を作らずに)2行目、3行目と貼り付けていきます。
    ⑤【Sheet2】にまだデータが残っているときに再度このマクロを実行する場合、一度【Sheet2】のA列、B列、E列、F列、G列、H列、I列のみの「数式も値も書式もすべてクリア」してから実行します(他の列は一切何もクリアしたり変更したりはしません)。
    ⑥【Sheet1】ではデータはコピーしますが、(切り取りではないから)【Sheet1】上のデータを編集したり変更したりは一切しません(データに変化があるのは、貼り付けられる【Sheet2】のみです)。
    ⑦【Sheet2】で貼り付けるのはA列、B列、E列、F列、G列、H列、I列のみですが、それはその他の列を強制的に空白セルに設定するという意味ではありません(C列やD列に元々データが存在するときがあるので、貼り付ける列以外の列はそのまま何も変更しないでいただけると助かります)。



    ※また、説明がかなりややこしいと思いますので、
    何か分かりにくいところがありましたら、
    このページでコメントをお願いします。


この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません