エクセルVBAについて質問です。次のページにあるようなマクロを作ってください。

http://hatena88.web.fc2.com/hatena/newpage1.shtml
なお、現在勉強中ですので、下記の質問の回答者4の方のような解説を付け加えてください。
http://q.hatena.ne.jp/1158311664

回答の条件
  • URL必須
  • 1人2回まで
  • 登録:2007/01/25 12:09:21
  • 終了:2007/01/25 17:16:40

回答(2件)

id:takashi_m17 No.1

たか回答回数104ベストアンサー獲得回数122007/01/25 17:09:56

ポイント100pt

質問ページの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

id:taroemon

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

とても助かりました。

2007/01/25 17:16:09
id:kn1967 No.2

kn1967回答回数2915ベストアンサー獲得回数3012007/01/25 17:15:49

ポイント10pt
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

  • id:taroemon
    kn1967 様ご回答ありがとうございます。

    解答受付終了した後に気づきましたので、
    こちらのコメントでお礼とさせていただきます。

    >どうしてURL必須なの?
    とのことでしたが、特に理由はありません。
    デフォルトの状態で、URL必須の方にチェックが付いているため、
    はずすのを忘れていました。

    また機会がありましたらご回答下さい。

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

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

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

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません