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

エクセルVBAについて質問です。

灰色(デフォルトの色)のシートの全ての内容を、「全部」という一つのシートにまとめ、
Q列にはまとめる前のシート名が記入されるというマクロを作成してください。

例えば、「sheet1」には10行目まで、
「sheet2」には20行目まで、何かが記入されているとします。
最後尾に「全部」というシートを作成して、
そのシートの1?10行目までが「sheet1」の内容となり、
Q1?Q10には「sheet1」と記入され、
11?30行目までは「sheet2」の内容となり、
Q11?Q30には「sheet2」と記入されるということです。

ただし、シートに色がついている場合は、この作業が行われません。
また、まとめる前のシート内に空白の行がある場合も、
空白のまま「全部」にコピーされるようにしてください。

なお、下記の点にご留意ください。
?それぞれのマクロがどう働くか「’」をもちいて説明してください。
?マクロは貼り付けてすぐに動くものをお願いします。
?質問が不明瞭でしたらコメントでご確認ください。

●質問者: taroemon
●カテゴリ:コンピュータ
✍キーワード:Q10 VBA エクセル コピー コメント
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

1 ● airplant
●180ポイント

次のマクロでどうでしょうか。

前類似のマクロを作ったことがありました。→前は、シート名を入れずに全部を集合させて、集合元のシートは削除してしまうものでした。

※集合シート名やシート名を入れる列の場所は、適宜変更ください。

'変数は必ず定義
Option Explicit

Sub シートを一つにまとめる()
' すべてのシートを「全部」シートにまとめる
 
 Const sTotalShtName As String = "全部"  '集合シート名
 Const sNameCol As String = "Q"  'シート名を入れる列
 Dim iSheetCNT As Integer  'sheetの個数
 Dim i As Integer
 Dim lCurRow As Long  '付け加えるsheetの行数
 Dim lTotalRow As Long  '集合シートの追加する行位置
 
  '全シート数を取り出し
 iSheetCNT = Sheets.Count
  '後ろへシートを追加して名前を変更
 Sheets.Add After:=Sheets(iSheetCNT)
 ActiveSheet.Name = sTotalShtName
 lTotalRow = 1

 For i = 1 To iSheetCNT
  'Copy元を選択してデータがある範囲をコピーする
 Worksheets(i).Select
  'シート見出しが色なしの場合だけ処理
 If ActiveSheet.Tab.ColorIndex = xlColorIndexNone Then
 Range("A1", ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Address).Select
 Selection.Copy
  'コピーした行数を記憶しておく
 lCurRow = Selection.Areas(1).Cells.Rows.Count
  'Copy先へ貼り付け(A列の追加行位置へ)
 Sheets(sTotalShtName).Select
 Range("A" & CStr(lTotalRow)).Select
 ActiveSheet.Paste
  '指定列へシート名を入れる(今回貼り付けの範囲へ)
 Range(sNameCol & lTotalRow, sNameCol & (lTotalRow + lCurRow)) = Worksheets(i).Name
  '集合シートは次の行位置に進める
 lTotalRow = lTotalRow + lCurRow
 End If
 Next i
 Range("A1").Select

End Sub
◎質問者からの返答

ご回答ありがとうございます。

望んでいた物ができました。

関連質問


●質問をもっと探す●



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