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

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



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



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




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

▽最新の回答へ

1 ● きゃづみぃ
●100ポイント
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


きゃづみぃさんのコメント
塗りつぶしの色や罫線などはコピーしてません。

ヘンリさんのコメント
きゃづみぃ さんへ ご回答いただきまして、ありがとうございます。 まず私の長い説明文を読んでいただいただけでもありがたいんですが。 塗りつぶしの色や罫線などはコピーできなくても、 私のしたいことの本質は捉えていただいたので テキストファイルに貼り付けて保存させていただきました。

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

こんな感じで、どうでしょう。標準モジュールに貼り付けて、サブルーチン 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


ヘンリさんのコメント
a-kuma3 さんへ 大変お世話になっております。 毎回、いろんな不都合が起きる可能性を予測したコードを教えていただきましてとても助かっております。 ありがとうございます。 ●【Sheet1 の B列には、空白のセルが無いことを前提にしました。】 ↑ この配慮、非常にありがたいですね。 まさにおっしゃっている通りの前提を自分も望んでいました。 ●【Sheet3 の書き込む先の行を決める際に、B列で何か値が入っているセルの次の行を書き込み行としています。】 ↑ これについても自分の説明が足りなかったのですが、この通りでございます。 的を射た想定、毎度感服しております。 何よりそのまま使えるコードの記述、感謝いたします。 ●【Sheet1 を全選択したときに泣きそうになると思うので、複写するセルの数に上限を設けてます。】 ↑ この配慮があるおかげで、保存する前にExcelが固まってしまい編集中のデータが全て消えてしまうという事態を防いでくれていると思うと、 ありがとうございます、しか言えないです。 ありがとうございます。 私の説明文の全て(わがまま)に対応していただいただけでなく、さらに上をいく機能を実現していただきまして とても嬉しいです! コメントも書いてくださっているので、私にも調整しやすいです。 「' 画面のちらつきを抑える」とかも優しい気遣いですね。ありがとうございます。 まとまらず、長くなりました。

ヘンリさんのコメント
a-kuma3 さんへ 何度も申し訳ございません。 教えていただいたコードを試していて、さらにこうなったらいいなというのが一個増えてしまいました。 ●セル選択だけでなく、 【Sheet1】で行番号を選択した場合でも(行番号を複数選択した場合でも)、 【Sheet3】に貼り付ける仕様を追加していただけないでしょうか。 お手数おかけしてすみません。 もし可能でしたら、よろしくお願いいたします。

a-kuma3さんのコメント
>> ●セル選択だけでなく、 【Sheet1】で行番号を選択した場合でも(行番号を複数選択した場合でも)、 【Sheet3】に貼り付ける仕様を追加していただけないでしょうか。 << 行を指定しちゃうと、選択したセル数が 50 まで、というチェックで処理を止めちゃうんですね。 というわけで、コードを見直したものを、回答に追記しました。

ヘンリさんのコメント
a-kuma3 さんへ ありがとうございます。 見事に行番号選択でも、【Sheet3】に貼り付けられるようになりました。 ですが、 今度は違う不具合を見つけてしまいました。 行番号を選択する場合ではなく、セルを選択する場合です。 どうやら空白のセルを選択すると(空白のセルを先頭にして空白ではないセルを連続選択した場合も)、 【Sheet3】でデータの重複を許すようです。 ・・・と思ったのですが、空白じゃないセルを選択した場合も重複することはあることが分かりました。 自分では、重複するパターン(法則)を見つけることはできませんでした。 そこで、違う言い方といいますか説明になってしまうのですが、 「一番はじめに教えていただいたコード(セル選択の場合)」の動作の結果はそのままに、 「行番号を選択した場合であっても、一番はじめに教えていただいたコードと同じ結果になる」コードに変化させることはできないものでしょうか。 これも無理難題かもしれませんので、 もし可能な場合のみご検討をよろしくお願いいたします。 また、分かりにくい説明でしたら、 どの辺りが分かりにくいのかをご指摘いただきたいです。

a-kuma3さんのコメント
>> 今度は違う不具合を見つけてしまいました。 << あ、本当ですね。ごめんなさい。 >|vb| If Sheets("Sheet3").Range("B:B").Find(What:=r.Cells(1, 2).Value, LookAt:=xlWhole) Is Nothing Then ||< ↑の r.Cells(1, 2).Value というのが駄目で、正しくは、↓のように r.<span style="color:red;">EntireRow.</span>Cells(1, 2).Value です。 >|vb| If Sheets("Sheet3").Range("B:B").Find(What:=r.EntireRow.Cells(1, 2).Value, LookAt:=xlWhole) Is Nothing Then ||< 行選択ではなく、セル選択で A列を含まない範囲を選択すると、重複の判定が正しく行われていなかったです。 ほぼ同じコードを 2回 貼ると間違えそうなので、失礼して、先の追記の一部を修正しました。

ヘンリさんのコメント
a-kuma3 さんへ 分かりやすく修正箇所を教えていただいた上で、 コード自体も修正していただきましてありがとうございます。 もう完全に理想通りの動作(と結果)になりました! 今回も最高の仕上がり、素晴らしすぎます。 今後も、もしよろしければよろしくお願いいたします。

ヘンリさんのコメント
a-kuma3 さんへ もし、見て頂いていたら嬉しいです。 何度も申し訳ありません。 動作自体はもう完璧なのですが、使っていて細かい部分でこうした方が(自分にとっては)いいなという箇所がありまして またお願いコメントをさせていただきます。 【Sheet1】を【Sheet3】にコピーするときなんですが、 ●【Sheet3】 ↓↓↓ G列、Q列、R列、S列、T列、U列のセルだけは色をそのままコピーしたいのですが、 それ以外の(全ての)列のセルは「塗りつぶしなし」の状態にしたいです。 (色は「塗りつぶしなし」ですが、罫線などのセルの書式はそのままコピーしていただきたいです。あくまで色だけの話になります。) 上記の条件を加えた(貼り付け方だけ変更させた)VBAコードを教えていただけないでしょうか。 もし見て頂いていたら、どうかよろしくお願いいたします。 (私の説明で分かりにくい部分がありましたら、ご指摘をお願いいたします。)

a-kuma3さんのコメント
値と書式を複写のところを、こんなふうに変更してください。 >|vb| ' 値と書式を複写 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 For c = 1 To 26 If c <> 7 And c <> 17 And c <> 18 And c <> 19 And c <> 20 Then Sheets("Sheet3").Rows(to_i).Cells(to_i, c).Interior.PatternColorIndex = 0 End If Next to_i = to_i + 1 ||< 「塗りつぶしなし」は、色だけではなく、塗りつぶしのパターンも含まれるので、白で塗りつぶしています。 塗りつぶしのパターンもクリアして良いなら、 >|vb| Sheets("Sheet3").Rows(to_i).Cells(to_i, c).Interior.PatternColorIndex = 0 ||< のところを、以下のようにすれば良いと思います。 >|vb| Sheets("Sheet3").Rows(to_i).Cells(to_i, c).Interior.Pattern = xlNone ||<

ヘンリさんのコメント
a-kuma3 さんへ こんなに早くご回答いただきましてありがとうございます。 さっそく今までのコードに、変更点を実装させていただきました。 ところが、今までと同じくG列、Q列、R列、S列、T列、U列以外の列のセルにも色が付いてしまいます。 これは私のコードの変更の仕方に間違いがあるかもしれませんので、下記のコードが合っているのかどうかご確認していただけないでしょうか。 ↓↓↓ 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 For c = 1 To 26 If c <> 7 And c <> 17 And c <> 18 And c <> 19 And c <> 20 Then Sheets("Sheet3").Rows(to_i).Cells(to_i, c).Interior.PatternColorIndex = 0 End If Next 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 もし間違っていましたら、訂正していただけると助かります。 何度もお付き合いいただきまして、どうもありがとうございます。

a-kuma3さんのコメント
>> もし間違っていましたら、訂正していただけると助かります。 << いえ、コードの変更の仕方が間違っているわけではありません。 IF 文のところを、以下のようにしてみたら、どうなるでしょうか。 >|vb| If c <> 7 And c <> 17 And c <> 18 And c <> 19 Then Set cc = Sheets("Sheet3").Rows(to_i).Cells(to_i, c) c_back = cc.Interior.PatternColorIndex cc.Interior.Pattern = xlNone cc.Interior.ColorIndex = c_back End If ||<

ヘンリさんのコメント
a-kuma3 さんへ ありがとうございます。 【IF 文のところを、以下のようにしてみたら、どうなるでしょうか。】 ↑↑ やはりこれでも今までと同じ結果になるようです。 (G列、Q列、R列、S列、T列、U列以外の列のセルにも色が付く結果になります。)

a-kuma3さんのコメント
また、何度も済みません。 こんな感じでしょうか。 >|vb| If c <> 7 And c <> 17 And c <> 18 And c <> 19 Then Sheets("Sheet3").Rows(to_i).Cells(to_i, c).Interior.ColorIndex = xlNone End If ||<

ヘンリさんのコメント
a-kuma3 さんへ いえ、私が勝手に我を通している側ですので、 お付き合いいただきましてありがとうございます。 【こんな感じでしょうか。】 ↑↑ やはりこれでも全く同じ結果になるみたいなんです。 お手数おかけして申し訳ありません。

a-kuma3さんのコメント
本当に、何度も済みません。 これでいけると思います。 >|vb| For c = 1 To 26 If c <> 7 And c <> 17 And c <> 18 And c <> 19 And c <> 20 Then Sheets("Sheet3").Rows(to_i).Cells(1, c).Interior.Color = xlNone End If Next ||< Z列よりも後まで対象にしたければ、26 を増やしてください。

ヘンリさんのコメント
a-kuma3 さんへ 何度もありがとうございます。 おっしゃる通り、いけました! これで私事にはなりますが、すごく便利なコードがまた1つ増えました。 繰り返しになりますが、 深夜に及ぶお付き合いありがとうございます。

a-kuma3さんのコメント
いやあ、上手くいって良かった。 やっぱり、VBA は苦手です (^^;

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

a-kuma3さんのコメント
たはは。 多少の負けず嫌いと、好奇心は、上達の妙薬だとは思ってます <tt>:-)</tt>

3 ● きゃづみぃ
●400ポイント
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

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


ヘンリさんのコメント
きゃづみぃ さんへ 書式まで対応したコードに変更していただきまして、ありがとうございます。 私のExcelは色分けで直感的に(見た目で)判断しているところもあるので、 (書式は非常に大事ということもあり、)今回のコードの修正はとても助かります。 実際に試させていただきましたが、ちゃんと重複にも対応していてエラーもありませんでした。 きゃづみぃさん、 この度はありがとうございます。
関連質問

●質問をもっと探す●



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