人力検索はてな
ﾓﾊﾞｲﾙ版を表示しています｡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.このﾍﾟｰｼﾞの先頭へ
□対応機種一覧
□お問い合わせ
□ﾍﾙﾌﾟ/お知らせ
□ﾛｸﾞｲﾝ
□無料ﾕｰｻﾞｰ登録
□はてなﾄｯﾌﾟ