id:egaosaiko
ポイントあり1500ptベストアンサーあり
コンピュータ

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




【Sheet1】で選択したセルの行を(1行ごとまるまる)コピーして
【Sheet3】に貼り付けるVBAコードを教えていただきたいです。



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

回答の条件
  • 1人3回まで
  • 登録：
  • 終了：2014/10/16 00:52:35
※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

ベストアンサー

id:a-kuma3 No.2

回答回数4973ベストアンサー獲得回数2154

ポイント1000pt

こんな感じで、どうでしょう。標準モジュールに貼り付けて、サブルーチン Append1To3 をボタンに登録してください。

Public Sub Append1To3()

    On Error GoTo ErrorHandler

    ' 画面のちらつきを抑える
    Application.ScreenUpdating = False

    Set s = Selection

    ' 選択されたセルの数が多すぎるときは、処理を中断
    If s.Count > 50 Then Exit Sub


    ' 書き込み行を決定
    Set last_b = Sheets("Sheet3").Cells(Rows.Count, 2).End(xlUp)
    If IsEmpty(last_b) Then
        to_i = 1
    Else
        to_i = last_b.Row + 1
    End If

    For Each c In s
        If Sheets("Sheet3").Range("B:B").Find(What:=c.EntireRow.Cells(1, 2).Value, LookAt:=xlWhole) Is Nothing Then
            ' 値と書式を複写
            Sheets("Sheet1").Rows(c.Row).Copy
            Sheets("Sheet3").Rows(to_i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Sheets("Sheet3").Rows(to_i).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            to_i = to_i + 1
        End If
    Next

    ' 最終行を、左下に表示
    Sheets("sheet3").Activate
    last_row = to_i - ActiveWindow.VisibleRange.Rows.Count + 1
    If last_row < 0 Then
        last_row = 1
    End If
    ActiveWindow.ScrollRow = last_row
    ActiveWindow.ScrollColumn = 1

FINAL:
    Application.ScreenUpdating = True
    Exit Sub

ErrorHandler:
    GoTo FINAL

End Sub

質問で書かれていなかったことを、ひとつ前提にしています。
Sheet1 の B列には、空白のセルが無いことを前提にしました。
Sheet3 の書き込む先の行を決める際に、B列で何か値が入っているセルの次の行を書き込み行としています。

後、Sheet1 を全選択したときに泣きそうになると思うので、複写するセルの数に上限を設けてます。
適宜、増やしてください。



追記です。

●セル選択だけでなく、
【Sheet1】で行番号を選択した場合でも(行番号を複数選択した場合でも)、
【Sheet3】に貼り付ける仕様を追加していただけないでしょうか。

行を指定しちゃうと、選択したセル数が 50 まで、というチェックで処理を止めちゃうんですね。
Selection.Areas というコレクションがあったので、これを使って処理を変えてみました。

Public Sub Append1To3()

    On Error GoTo ErrorHandler

    ' 画面のちらつきを抑える
    Application.ScreenUpdating = False

    Set s = Selection

    ' 選択された列数が多すぎるときは、処理を中断
    n_rows = 0
    For Each a In s.Areas
        n_rows = n_rows + a.Rows.Count
    Next
    If n_rows > 20 Then
        MsgBox "Too much cells !  " & n_rows
        Exit Sub
    End If


    ' 書き込み行を決定
    Set last_b = Sheets("Sheet3").Cells(Rows.Count, 2).End(xlUp)
    If IsEmpty(last_b) Then
        to_i = 1
    Else
        to_i = last_b.Row + 1
    End If

    For Each a In s.Areas
        For Each r In a.Rows
            If Sheets("Sheet3").Range("B:B").Find(What:=r.EntireRow.Cells(1, 2).Value, LookAt:=xlWhole) Is Nothing Then
                ' 値と書式を複写
                Sheets("Sheet1").Rows(r.Row).Copy
                Sheets("Sheet3").Rows(to_i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Sheets("Sheet3").Rows(to_i).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                to_i = to_i + 1
            End If
        Next
    Next

    ' 最終行を、左下に表示
    Sheets("sheet3").Activate
    last_row = to_i - ActiveWindow.VisibleRange.Rows.Count + 1
    If last_row < 0 Then
        last_row = 1
    End If
    ActiveWindow.ScrollRow = last_row
    ActiveWindow.ScrollColumn = 1

FINAL:
    Application.ScreenUpdating = True
    Exit Sub

ErrorHandler:
    GoTo FINAL

End Sub

結構、遅かったので、選択した行の上限を 20 に変えました。
上限を超えたときには、音なしで終了するのではなく、MsgBox でメッセージを表示します。


追記です。
2回目に貼ったコードの一部が間違っていたので、一部分を差し替えました。
ご了承ください　m(_ _)m

他16件のコメントを見る
id:egaosaiko

これで苦手なわけがありません。
すごい対応力と根気(?)、尊敬しております。

2014/10/19 01:27:12
id:a-kuma3

たはは。
多少の負けず嫌いと、好奇心は、上達の妙薬だとは思ってます　:-)

2014/10/19 01:34:13

その他の回答（2件）

id:taknt No.1

回答回数13539ベストアンサー獲得回数1198

ポイント100pt 
Sub Macro2()
    
    For aa = 1 To Selection.Count
        ee = Selection(aa).Row
        bb = Cells(ee, Columns.Count).End(xlToLeft).Column
        
        For d = 1 To Rows.Count
            f = 1
            cc = 0
            For e = 1 To bb
                If Sheets("Sheet3").Cells(d, e) = "" Then cc = cc + 1
                If Cells(ee, e) <> Sheets("Sheet3").Cells(d, e) Then
                    f = 2
                End If
            Next e
            If f = 1 Then Exit For
            If cc = bb Then Exit For
        Next d
        
        If f = 2 Then
            For h = 1 To bb
                Sheets("Sheet3").Cells(d, h) = Cells(ee, h)
            Next h
        End If
    
    
    Next aa
    
  
End Sub
id:taknt

塗りつぶしの色や罫線などはコピーしてません。

2014/10/15 08:30:51
id:egaosaiko

きゃづみぃ さんへ

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

まず私の長い説明文を読んでいただいただけでもありがたいんですが。


塗りつぶしの色や罫線などはコピーできなくても、
私のしたいことの本質は捉えていただいたので
テキストファイルに貼り付けて保存させていただきました。

2014/10/15 20:42:15
id:a-kuma3 No.2

回答回数4973ベストアンサー獲得回数2154ここでベストアンサー

ポイント1000pt

こんな感じで、どうでしょう。標準モジュールに貼り付けて、サブルーチン Append1To3 をボタンに登録してください。

Public Sub Append1To3()

    On Error GoTo ErrorHandler

    ' 画面のちらつきを抑える
    Application.ScreenUpdating = False

    Set s = Selection

    ' 選択されたセルの数が多すぎるときは、処理を中断
    If s.Count > 50 Then Exit Sub


    ' 書き込み行を決定
    Set last_b = Sheets("Sheet3").Cells(Rows.Count, 2).End(xlUp)
    If IsEmpty(last_b) Then
        to_i = 1
    Else
        to_i = last_b.Row + 1
    End If

    For Each c In s
        If Sheets("Sheet3").Range("B:B").Find(What:=c.EntireRow.Cells(1, 2).Value, LookAt:=xlWhole) Is Nothing Then
            ' 値と書式を複写
            Sheets("Sheet1").Rows(c.Row).Copy
            Sheets("Sheet3").Rows(to_i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Sheets("Sheet3").Rows(to_i).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            to_i = to_i + 1
        End If
    Next

    ' 最終行を、左下に表示
    Sheets("sheet3").Activate
    last_row = to_i - ActiveWindow.VisibleRange.Rows.Count + 1
    If last_row < 0 Then
        last_row = 1
    End If
    ActiveWindow.ScrollRow = last_row
    ActiveWindow.ScrollColumn = 1

FINAL:
    Application.ScreenUpdating = True
    Exit Sub

ErrorHandler:
    GoTo FINAL

End Sub

質問で書かれていなかったことを、ひとつ前提にしています。
Sheet1 の B列には、空白のセルが無いことを前提にしました。
Sheet3 の書き込む先の行を決める際に、B列で何か値が入っているセルの次の行を書き込み行としています。

後、Sheet1 を全選択したときに泣きそうになると思うので、複写するセルの数に上限を設けてます。
適宜、増やしてください。



追記です。

●セル選択だけでなく、
【Sheet1】で行番号を選択した場合でも(行番号を複数選択した場合でも)、
【Sheet3】に貼り付ける仕様を追加していただけないでしょうか。

行を指定しちゃうと、選択したセル数が 50 まで、というチェックで処理を止めちゃうんですね。
Selection.Areas というコレクションがあったので、これを使って処理を変えてみました。

Public Sub Append1To3()

    On Error GoTo ErrorHandler

    ' 画面のちらつきを抑える
    Application.ScreenUpdating = False

    Set s = Selection

    ' 選択された列数が多すぎるときは、処理を中断
    n_rows = 0
    For Each a In s.Areas
        n_rows = n_rows + a.Rows.Count
    Next
    If n_rows > 20 Then
        MsgBox "Too much cells !  " & n_rows
        Exit Sub
    End If


    ' 書き込み行を決定
    Set last_b = Sheets("Sheet3").Cells(Rows.Count, 2).End(xlUp)
    If IsEmpty(last_b) Then
        to_i = 1
    Else
        to_i = last_b.Row + 1
    End If

    For Each a In s.Areas
        For Each r In a.Rows
            If Sheets("Sheet3").Range("B:B").Find(What:=r.EntireRow.Cells(1, 2).Value, LookAt:=xlWhole) Is Nothing Then
                ' 値と書式を複写
                Sheets("Sheet1").Rows(r.Row).Copy
                Sheets("Sheet3").Rows(to_i).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Sheets("Sheet3").Rows(to_i).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                to_i = to_i + 1
            End If
        Next
    Next

    ' 最終行を、左下に表示
    Sheets("sheet3").Activate
    last_row = to_i - ActiveWindow.VisibleRange.Rows.Count + 1
    If last_row < 0 Then
        last_row = 1
    End If
    ActiveWindow.ScrollRow = last_row
    ActiveWindow.ScrollColumn = 1

FINAL:
    Application.ScreenUpdating = True
    Exit Sub

ErrorHandler:
    GoTo FINAL

End Sub

結構、遅かったので、選択した行の上限を 20 に変えました。
上限を超えたときには、音なしで終了するのではなく、MsgBox でメッセージを表示します。


追記です。
2回目に貼ったコードの一部が間違っていたので、一部分を差し替えました。
ご了承ください　m(_ _)m

他16件のコメントを見る
id:egaosaiko

これで苦手なわけがありません。
すごい対応力と根気(?)、尊敬しております。

2014/10/19 01:27:12
id:a-kuma3

たはは。
多少の負けず嫌いと、好奇心は、上達の妙薬だとは思ってます　:-)

2014/10/19 01:34:13
id:taknt No.3

回答回数13539ベストアンサー獲得回数1198

ポイント400pt 
Sub Macro3()
    Application.ScreenUpdating = False
    For aa = 1 To Selection.Count
        ee = Selection(aa).Row
       
        For d = 1 To Rows.Count
            f = 1
            cc = 0
            If Cells(ee, 2) <> Sheets("Sheet3").Cells(d, 2) Then f = 2 Else Exit For
            If Sheets("Sheet3").Cells(d, 2) = "" Then f = 2: Exit For
        Next d
        
        If f = 2 Then
            Rows(ee).Copy
            Sheets("Sheet3").Rows(d).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
            Sheets("Sheet3").Rows(d).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
                :=False, Transpose:=False
            Application.CutCopyMode = False
        End If
    Next aa
    Sheets("Sheet3").Select
    ActiveCell.SpecialCells(xlLastCell).Select
    Application.ScreenUpdating = True
End Sub

書式もコピーするようにしました。

id:egaosaiko

きゃづみぃ さんへ

書式まで対応したコードに変更していただきまして、ありがとうございます。

私のExcelは色分けで直感的に(見た目で)判断しているところもあるので、
(書式は非常に大事ということもあり、)今回のコードの修正はとても助かります。

実際に試させていただきましたが、ちゃんと重複にも対応していてエラーもありませんでした。

きゃづみぃさん、
この度はありがとうございます。

2014/10/16 00:50:32

コメント（1件)

  • id:egaosaiko
    ヘンリ 2014/10/15 00:16:26

    (ここまで見ていただいてありがとうございます。)




    もっと具体的に言いますと、

    【Sheet1】のどこのセルを選択した場合でも(複数のセルを選択した場合でも)、その選択したセルがある行を(一行ごと)コピーして、
    【Sheet3】に貼り付けるVBAコードが知りたいです。


    たとえば、
    【Sheet1】に以下のようにデータがあるときに【E1】を選択した場合は
    E1は1行目なので(E1に何かデータがあってもなくても1行目なので)


    ●【Sheet1】
    A1：
    B1：あ
    C1：い
    D1：う

    ↓↓↓

    ●【Sheet3】
    A1：
    B1：あ
    C1：い
    D1：う

    このように【Sheet1】の1行目をそっくりそのまま貼り付けます。





    また、【Sheet1】のデータを【Sheet3】に貼り付けるときは以下の6つの条件を満たしていただけると嬉しいです。

    ①【Sheet3】には、極力上の行から貼り付けていきます(行を空けずに)。
    そして、実行するたびに、
    【Sheet3】の行ごとのデータは(クリアせずに)どんどん上から張り付けていき、
    データが増えていく仕様にしたいです。


    上の例の続きという流れで言いますと、
    すでに【Sheet3】の1行目には

    【Sheet3】
    A1：
    B1：あ
    C1：い
    D1：う

    という風にデータが貼り付けられているので、
    その【Sheet3】の1行目を残したままで次の実行を待つというイメージです。
    (次に実行された場合は、2行目に貼り付けます。)



    ②【Sheet1】のセル選択に対しては、複数選択にも対応できるようにしたいです。
    例えば、
    縦にも(例：A1～A5などの連続行選択)、横にも(例：A1～E1など)対応できる仕様です。
    また、
    離れたセル選択(例：A1、A5、D8など←これだと3行分になる)にも対応できる仕様が理想的です。



    ③貼り付けるとき
    【Sheet3】のB列の文字列が重複した場合(部分的な重複ではなく、B列の文字列が完全に一致した場合のみ)は、
    その行は貼り付けないという仕様にしたいです。
    (先に存在しているB列の方だけを残して、後から重複した方は貼り付けないようにしたいです。)



    ④貼り付けた後はExcel画面を【Sheet3】に移動して、
    データのある最終行が見えるところまで画面をスクロールするようにしたいです(スクロールバーは右と下に付いていますが、下のスクロールバーは一番左の位置、右のスクロールバーはデータの最終行が見えるところまで移動というのが理想です)。
    アクティブセルの位置はどこでも問題ありません。



    ⑤数式ではなく、すべて｢値として｣【Sheet3】に貼り付けしたいです。
    また値だけでなく、塗りつぶしの色や罫線などもコピーして【Sheet3】に貼り付ける仕様にしたいのです(が、可能でしょうか)。



    ⑥コマンドボタンに登録できるVBAコードを教えていただきたいです。





    ※ここまでで、説明が分かりにくい部分がありましたら、
    コメント欄でご指摘をお願いいたします。


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

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

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

回答リクエストを送信したユーザーはいません
ユーザー登録をして使いはじめる!無料
すでに登録されている方はこちらからログイン
この質問に含まれるキーワード
知りたいことを検索してみよう
▲ページトップへ