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

エクセルVBAについて質問です。次のページにあるようなマクロを作ってください。
http://hatena88.web.fc2.com/hatena/newpage1.shtml
なお、現在勉強中ですので、下記の質問の回答者4の方のような解説を付け加えてください。
http://q.hatena.ne.jp/1158311664

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

▽最新の回答へ

1 ● たか
●100ポイント

質問ページのsheet2,sheet3を以下データシートと表記します。

Sub Sample()
 Dim mySelect
 Dim st As Worksheet
 Dim sActive As String
 Dim NewSheet As String
 Dim nx, ny As Integer
 Dim x, y As Integer
 Dim hx, hy As Integer
 Dim hnx, hny As Integer
 
 x = 1
 y = 2
'xはデータシートの横開始位置に対応し1=A列目となります。データの場所により可変
'yはデータシートの縦開始位置に対応し1=1行目となります。データの場所により可変
'sheet2,sheet3のデータの場所がD1からであればx=4,y=1となります
 nx = 1
 ny = 1
'nxは合計シートの横の始まりに対応しています
'nyは合計シートの縦の始まりに対応しています
'(nx=2,ny=3)と設定すれば合計シートのB3からデータが入ります


 sActive = ActiveSheet.Name
 Set mySelect = ActiveWindow.SelectedSheets
'複数選択されたシート情報をmySelectへ取得しています
 
 
 For Each st In Worksheets
 If st.Name <> sActive Then
 st.Select
 Exit For
 End If
 Next st
'1つのシートのみを選択状態にし、シート追加時の複数追加を防ぎます
 
 
 Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
 ActiveSheet.Name = "合計"
'一番最後にシートを追加し、名前を「合計」にします
 
 
 hnx = nx
 hny = ny
'hnx,hnyは合計シートのデータコピー場所になります
 
 For Each st In mySelect
'複数選択されたシートを一つずつstに返し、以下の処理を繰り返します
 
 st.Select
 For hy = y To 100
'データシートのy軸が100になるまで以下を繰り返します(100は可変)

 If (st.Cells(hy, x) = "") Then
 Exit For
 End If
'データシートのセル(hy,x)が空白であれば当forを抜ける
 
 For hx = x To 100
 If (st.Cells(hy, hx) = "") Then
 hnx = nx
 Exit For
 End If
'セル(hy,hx)が空白であれば合計ページの値入力セルを初期値(一番左)へ戻し、forを抜ける

 Sheets("合計").Cells(hny, hnx) = st.Cells(hy, hx)
'セル(hy,hx)の値を合計ページのセル(hny,hnx)へコピーする
 
 hnx = hnx + 1
'合計ページの値入力セルを右へ1つずらす
 
 Next
 hny = hny + 1
'合計ページの値入力セルを下へ1つずらす

 Next
 Next st
 Sheets("合計").Select
End Sub


長くなっちゃいましたが、、、

http://q.hatena.ne.jp/1169694559

◎質問者からの返答

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

とても助かりました。


2 ● kn1967
●10ポイント
Sub Macro1()
 Dim S_Range As String
 Dim obj_Sheets As Sheets
 Dim obj_Sheet As Worksheet
 Dim L_Top As Long
 Dim L_Bottom As Long
 Dim I_Left As Integer
 Dim I_Right As Integer
 Dim I_ColumnCount As Integer
 Dim L_Count As Long
 Dim L_Position As Long
 
 S_Range = "A:E": 'ここではA列からE列と設定
 L_Top = 2: '1行目は不要という事でスタートは2

 I_Left = Range(S_Range).End(xlToLeft).Column: '一番左列の列番号
 I_Right = Range(S_Range).End(xlToRight).Column: '一番右列の列番号
 
 Set obj_Sheets = ActiveWindow.SelectedSheets: '選択されているシート群を一旦オブジェクト変数に収納
 
 Sheets.Add after:=Sheets(Sheets.Count), Count:=1: '一番後のシートの後ろに1シート追加
 Sheets(Sheets.Count).Name = "合計": 'シート見出し
 L_Position = 1: '合計シートの何行目から追記するのかを記憶

 For Each obj_Sheet In obj_Sheets: 'シート群の中から1シートを選択

 L_Bottom = 0: ' 一番最後の行を探すため一旦ゼロにする
 For lp = I_Left To I_Right: ' 各列毎に終端行を探して一番大きな数値を採用する
 L_Bottom = IIf(L_Bottom > obj_Sheet.Cells(65535, lp).End(xlUp).Row, L_Bottom, obj_Sheet.Cells(65535, lp).End(xlUp).Row)
 Next lp

 obj_Sheet.Select: 'シート選択
 obj_Sheet.Range(Cells(L_Top, I_Left), Cells(L_Bottom, I_Right)).Copy: 'コピー
 Sheets("合計").Select: 'シート選択
 Range(Cells(L_Position, 1), Cells(L_Position, 1)).PasteSpecial: '貼り付け
 L_Position = L_Position + L_Bottom - L_Top + 1: 'データ行数を加算

 Next obj_Sheet
 
 obj_Sheets.Select: '元もと選択されていた状態に戻す
End Sub

Excel2000で動作確認済みです。他のバージョンでも動くとは思いますが確証は持てません。

元データの範囲選択のほうは多少融通の利く形にはしてあります。

合計という名のシートが既に存在する場合はエラーとなります。

エラー処理は特に行っていないので適宜継ぎ足してください。


どうしてURL必須なの?

http://office.microsoft.com/ja-jp/excel/default.aspx

関連質問


●質問をもっと探す●



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