[[20110301184111]] 『1つのシートをグループ毎に分割する際、テンプレメx(TRO) >>BOT

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『1つのシートをグループ毎に分割する際、テンプレシートを使用したい』(TRO)
  
過去ログの[[20050721182519]]を見て、分割する方法はできたのですが、
 シートの分割の際、シートのテンプレートを使用するようにはできないでしょうか。
[[20080522180917]]を見て、色々試しては見たのですが、歯が立ちません。
 
[[20050721182519]]にて(Mook)さんが作られたマクロです。

 '=================================
 Sub Grouping()
 '=================================
    Dim i%
    Application.ScreenUpdating = False
    With Worksheets(1)
        For i = 2 To .Range("B65535").End(xlUp).Row
            Call AddLine(i, .Cells(i, 2).Value )
        Next
    End With
    Application.ScreenUpdating = True
End Sub
 '=================================
 Sub AddLine(lineNum%, sheetName$)
 '=================================
    Dim lastLine%
    Call checkAndMake(sheetName)
    lastLine = Worksheets(sheetName).Range("B65535").End(xlUp).Row + 1
    Worksheets(1).Rows(lineNum).Copy
    Worksheets(sheetName).Rows(lastLine).Insert Shift:=xlDown
End Sub
 '=================================
 Sub checkAndMake(sheetName$)
 '=================================
    Dim tmpWS As Worksheet
    On Error Resume Next
    Set tmpWS = Worksheets(sheetName)
    If tmpWS Is Nothing Then
        Worksheets.Add after:=Worksheets(Worksheets.Count)
        Worksheets(Worksheets.Count).name = sheetName
        Worksheets(1).Rows(1).Copy
        Worksheets(sheetName).Rows(1).Insert Shift:=xlDown
    End If
    On Error GoTo 0
End Sub

 このマクロを使う際、テンプレートに設定してあるシートを適用したいのです。
お分かりの方、ご教示いただけたら幸いです。
よろしくお願いいたします。
エクセルのバージョン Excel2003
OSのバージョン WindowsXP

 懐かしいコードですね。

 Worksheets.Add after:=Worksheets(Worksheets.Count)
 を
 Worksheets.Add after:=Worksheets(Worksheets.Count), Type="テンプレートファイルの完全パス"
 にしてできないでしょうか。
 (Mook)


Mookさん、ありがとうございます!
作った人に見てもらえるとは、感激です。

それで実際にやってみたのですが、
コンパイルエラー:修正候補:名前付き引数
と出て、Typeが反転して、文全体が赤字になってしまいます。

自分でも調べてみたり、いじってみたりしたのですが、うまくいきません。
お力お借りできたら嬉しいです。
よろしくお願いいたします。
(TRO)


 あっ、ごめんなさい。

 名前付き引数は
   Type= ではなく  Type:= です。
 =の前に:を追加して試してみてください。
 (Mook)

Mookさんありがとうございます!
修正したところエラーも出ずマクロは動作したんですが、結果が変わってしまいました。
シートは分割されず、シート名が一番最後のグループ名に変わり、
タイトル列が2列目以降にいくつかコピー&挿入されたようになりました。

テンプレートファイルのパスは多分あっていて、
テンプレート自体はある程度適応されているようです。

これは何が問題なんでしょう?
(TRO)


 むむ、ちょっとまじめに考えないといけないようですね。
 今回ベースにしているのは、[[20050721182519]] と [[20080522180917]] の
 どちらのコードでしょうか。

 後者であれば、コピー元のシートをそのまま使用しますので、同じ書式であれば
 テンプレートファイルの導入は不要だと思いますが、それをテンプレートに
 したいということでしょうか。
 その場合はこれまでの枠組みではできないので、単純な変更ではできない気が
 します。

 もしコピー元と同じシート形式でよいのであれば、後者では対応したつもりなの
 で、パラメータを正しく設定しているかの確認となりますが、そのあたりから
 説明いただけますか?
 (Mook)

 今回ベースにしているのは[[20050721182519]]のコードです。

 [[20080522180917]]のコードも試してみたのですが、
 実行時エラー '9':
 インデックスが有効範囲にありません
 と出て、デバックを押すと、With ThisWorkbook.WorkSheets(masterSheetName)
 の行の左に黄色い矢印が出て、文章が反転されています。

 マクロの上部で設定する元データシート名は合っているはずなのですが……。

 グループの分割判定はB列、各シートの最終列を判定する列はデータが埋まっているD列、
 コピー行単位は1、データ開始行は2にしてあります。

 ちなみに元データは以下のような感じです。

   A   B   C   D  
 1(空白)品名  No.  産地                      
 2    りんご  1   青森                      
 3    りんご  2   秋田                       
 4    ばなな  1   青森                       
 5    ばなな  2   秋田

 シート名は"Sheet1"で、そのブックにはそのシートしかありません。

 何度もすみませんが、どうかよろしくお願いいたします。
 (TRO)

 Const masterSheetName = "Sheet1"
 にしているでしょうか。
 (シート名は直接シートタブからコピーした方が間違いはないですね。)

 マクロを実行しているファイルとマスタシートは同一ブックですか?
 どちらも異なる場合は、また情報をお願いします。
 (Mook)

 Mookさん、上手くいきました!
 結論としては、マクロを保存しているファイルが別ブックだったことが問題だったようです。
 シート名は問題なかったです。

 お騒がせしてすみません、そして本当にありがとうございます。

 厚かましくも最後にもう一つ、質問させてください。

 [[20080522180917]]のコードでは新規ブックとして作成される仕様になっていますが、
 [[20050721182519]]のコードのように、元のシートの中で分割するようにはできませんでしょうか。

 ご教示いただけたら幸いです。
 (TRO)

 あまり代わり映えしませんが、オプションを二つ追加しコードを修正しました。
 自ブックで複数回実行すると同じデータが何度も登録されるというのが
 新規ブックで作成した理由でしたので、あわせて追記するのか再作成するのか
 のモードも追加しています。

 '//--------------------------------------------------------
 '// 処理:データを種類ごとにシートに分類
 '//--------------------------------------------------------
 '// 処理するファイル内にマクロを置いて実行してください。
 '//--------------------------------------------------------
 Option Explicit

 '//--------------------------------------------------------
 '// ファイルに併せて設定
 '//--------------------------------------------------------
 Const masterSheetName = "ALL"   '--- 元データシート名
 Const checkCol = "E"            '--- 元データの分割判定を行う列
 Const checkLastCol = "C"        '--- 各シートの最終列を判定する列
 Const rowUnitSize = 1           '--- コピー行単位
 Const dataStartLine = 3         '---  各シートのデータ開始行(ヘッダ行+1)

 '//--------------------------------------------------------
 '// オプション
 '//--------------------------------------------------------

 '//-------------------------
 '// 1)処理先ファイルの指定
 '// True ・・・ 新規ファイルで作成
 '// False ・・・ 自ブック内に作成
  Const makeNewFile = False

 '//-------------------------
 '// 2)追記モードの指定
 '// 上記の 1) オプションが False のときのみ有効
 '// True ・・・ データを追記    ★注意:2回実行すると同じものが追加されます
 '// False ・・・ データ再登録   ★注意:Master シート以外をすべて再作成します
  Const appendMode = False

 '//--------------------------------------------------------
 Const tmpSheetName = "TMP"      '--- 作業用テンプレートシート名

 '//--------------------------------------------------------
 Sub Grouping()
 '//--------------------------------------------------------
    Dim i&, lastRow
    Dim dstWB As Workbook
    Dim ws As Worksheet

    '//--- 開始処理
    Application.ScreenUpdating = False

    With ThisWorkbook.Worksheets(masterSheetName)
        lastRow = .Range(checkCol & Rows.Count).End(xlUp).Row
        If makeNewFile = True Then
            .Copy
            Set dstWB = ActiveWorkbook
            dstWB.Worksheets(masterSheetName).Name = tmpSheetName
            dstWB.Worksheets(tmpSheetName).Rows(dataStartLine & ":" & Rows.Count).Clear
        Else
            If appendMode = False Then
                If MsgBox(masterSheetName & "以外を再作成します。よろしいですか?", vbYesNo) = vbNo Then
                    Exit Sub
                End If
                Application.DisplayAlerts = False
                For Each ws In ThisWorkbook.Worksheets
                    If ws.Name <> masterSheetName Then
                        ws.Delete
                    End If
                Next
                Application.DisplayAlerts = True
            End If

            Set dstWB = ThisWorkbook
            .Copy after:=ThisWorkbook.Worksheets(1)
            dstWB.Worksheets(2).Name = tmpSheetName
            dstWB.Worksheets(tmpSheetName).Rows(dataStartLine & ":" & Rows.Count).Clear
        End If

        For i = dataStartLine To lastRow
            If .Cells(i, checkCol).Value <> "" Then
                AddLine dstWB, i, .Cells(i, checkCol).Value
            End If
        Next
    End With

    '//--- 終了処理
    Application.DisplayAlerts = False
    dstWB.Worksheets(tmpSheetName).Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    '//--- 表示位置の調整
    sortSheet dstWB
    For Each ws In dstWB.Worksheets
         Application.Goto Reference:=ws.Range("A1"), Scroll:=True
    Next
    dstWB.Worksheets(1).Activate
 End Sub

 '//--------------------------------------------------------
 Private Sub AddLine(dstWB As Workbook, lineNum&, sheetName$)
 '//--------------------------------------------------------
 ' コピー先シートにデータをコピー
 '---------------------------------
    Dim lastLine%

    checkAndMake dstWB, sheetName
    lastLine = dstWB.Worksheets(sheetName).Range(checkLastCol & Rows.Count).End(xlUp).Row + 1
    ThisWorkbook.Worksheets(masterSheetName).Rows(lineNum & ":" & lineNum + rowUnitSize - 1).Copy
    dstWB.Worksheets(sheetName).Rows(lastLine).Insert Shift:=xlDown
 End Sub

 '//--------------------------------------------------------
 Private Sub checkAndMake(dstWB As Workbook, sheetName$)
 '//--------------------------------------------------------
 ' コピー先シートがあるかチェックしなければ作成
 '---------------------------------
    Dim tmpWS As Worksheet
    On Error Resume Next
    Set tmpWS = dstWB.Worksheets(sheetName)
    If tmpWS Is Nothing Then
        dstWB.Worksheets(tmpSheetName).Copy after:=dstWB.Worksheets(dstWB.Worksheets.Count)
        dstWB.Worksheets(dstWB.Worksheets.Count).Name = sheetName
    End If
    On Error GoTo 0
 End Sub
 '//--------------------------------------------------------
 ' シートを名前順でソート
 '---------------------------------
 Private Sub sortSheet(dstWB As Workbook)
    Dim i%, j%, startI%

    If makeNewFile = True Then
        startI = 1
    Else
        startI = 2
    End If

    For i = startI To dstWB.Worksheets.Count - 1
        For j = i + 1 To dstWB.Worksheets.Count
            If StrComp(dstWB.Worksheets(i).Name, dstWB.Worksheets(j).Name) > 0 Then
                dstWB.Worksheets(j).Move before:=dstWB.Worksheets(i)
            End If
        Next
    Next
 End Sub

 (Mook)


 Mookさん

 かゆいところに手が届く仕様にしていただいてありがとうございます!
 今回本当に助かりました。

 色々と無理ばかりを言って申し訳ありませんでしたが、
 これを機に、自分でも少しマクロを勉強してみたいと思います。

 本当にありがとうございました。
 (TRO)

 ソートがうまくいってなかったので、ちょっと修正。

 このマクロは思い入れもあるものなので、今回はいろいろと手を入れてみました。
 マクロ習熟のきっかけにでもなれば、私も嬉しく思います。
 がんばってください。
 (Mook)

Mookさん
マクロ初心者です。20080522180917を参考にアレンジしようとしています。
マクロは別ファイルにしたいのですが、どこを変えれば宜しいでしょうか?
お手数ですがご教示願います。
(Toshi)


 上のコードは自ファイルを処理するようにしていますので、ThisWorkbook と書かれている部分を処理する
 ブックに変更してあげれば出来るかと思います。

 処理するファイルをどう指定するかは作り方しだいですが、最初に処理用のブックオブジェクトや
 シートオブジェクトの変数を用意し、それを ThisWorkbook と ThisWorkbook.WorkSheets(masterSheetName)
 の代りに全体で使うようにしてみてはどうでしょうか。
 (Mook)

 だいぶ古い板ですが、他ファイルを処理する機能追加版です。
 他にも 65536 行以上を処理しようとすると(2003の頃はこんなことは無かったのですが)、
 エラーになっていたので、修正しました。

 ついでに、最近私の中のマイブームの日本語コード化しました。
 (Mook)

 '//--------------------------------------------------------
 '// 処理:データを種類ごとにシートに分類
 '//--------------------------------------------------------
 '// 処理するファイル内にマクロを置いて実行してください。
 '//--------------------------------------------------------
 Option Explicit

 '//--------------------------------------------------------
 '// ファイルに併せて設定
 '//--------------------------------------------------------
 Const データシート名 = "Data"  '--- 元データシート名
 Const 分類列 = "C"             '--- 元データの分割判定を行う列
 Const データ判定列 = "E"       '--- 各シートの最終列を判定する列
 Const コピー処理単位行数 = 1   '--- コピー行単位
 Const データ開始行 = 3         '---  各シートのデータ開始行(ヘッダ行+1)

 '//--------------------------------------------------------
 '// オプション
 '//--------------------------------------------------------

 '//-------------------------
 '// 1)処理先ファイルの指定
 '// True ・・・ 新規ファイルで作成
 '// False ・・・ 自ブック内に作成
  Const オプション_新規ファイル作成 = False

 '//-------------------------
 '// 2)追記モードの指定
 '// 上記の 1) オプションが False のときのみ有効
 '// True ・・・ データを追記    ★注意:2回実行すると同じものが追加されます
 '// False ・・・ データ再登録   ★注意:Master シート以外をすべて再作成します
  Const オプション_データ追記 = False

 '//--------------------------------------------------------
 Const 作業シート名 = "TMP"      '--- 作業用テンプレートシート名

 '//--------------------------------------------------------
 '// ★アクティブなシートを処理する場合はこちらを実行
 '//--------------------------------------------------------
 Sub データをシートに分類処理_アクティブWBを処理()
 '//--------------------------------------------------------
    Dim データWB As Workbook
    Dim データWS As Worksheet

    Set データWB = ActiveWorkbook
    Set データWS = ActiveSheet

    データをシートに分類処理 データWB, データWS
 End Sub

 '//--------------------------------------------------------
 '// ★自ブックの定義で規定したシートを処理する場合はこっちを実行(従来版の動作)
 '//--------------------------------------------------------
 Sub データをシートに分類処理_自ブックを処理()
 '//--------------------------------------------------------
    Dim データWB As Workbook
    Dim データWS As Worksheet

    Set データWB = ThisWorkbook
    Set データWS = ThisWorkbook.Worksheets(データシート名)

    データをシートに分類処理 データWB, データWS
 End Sub

 '//--------------------------------------------------------
 Sub データをシートに分類処理(データWB As Workbook, データWS As Worksheet)
 '//--------------------------------------------------------
    Dim 最終行 As Long
    Dim 出力WB As Workbook
    Dim 処理WS As Worksheet
    '//--- 開始処理
    Application.ScreenUpdating = False

    With データWS
        最終行 = .Cells(Rows.Count, 分類列).End(xlUp).Row
        If オプション_新規ファイル作成 = True Then
            .Copy
            Set 出力WB = ActiveWorkbook
            出力WB.Worksheets(データWS.Name).Name = 作業シート名
            出力WB.Worksheets(作業シート名).Rows(データ開始行 & ":" & Rows.Count).Clear
        Else
            If オプション_データ追記 = False Then
                If MsgBox(データWS.Name & "以外を再作成します。よろしいですか?", vbYesNo) = vbNo Then
                    Exit Sub
                End If
                Application.DisplayAlerts = False
                For Each 処理WS In データWB.Worksheets
                    If 処理WS.Name <> データWS.Name Then
                        処理WS.Delete
                    End If
                Next
                Application.DisplayAlerts = True
            End If

            Set 出力WB = データWB
            .Copy after:=データWB.Worksheets(1)
            出力WB.Worksheets(2).Name = 作業シート名
            出力WB.Worksheets(作業シート名).Rows(データ開始行 & ":" & Rows.Count).Clear
        End If

     Dim 処理行 As Long
        For 処理行 = データ開始行 To 最終行
            If .Cells(処理行, 分類列).Value <> "" Then
                行追加処理 出力WB, データWS, 処理行, .Cells(処理行, 分類列).Value
            End If
        Next
    End With

    '//--- 終了処理
    Application.DisplayAlerts = False
    出力WB.Worksheets(作業シート名).Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

    '//--- 表示位置の調整
    シート並べ替え処理 出力WB
    For Each 処理WS In 出力WB.Worksheets
         Application.Goto Reference:=処理WS.Range("A1"), Scroll:=True
    Next
    出力WB.Worksheets(1).Activate
 End Sub

 '//--------------------------------------------------------
 Private Sub 行追加処理(出力WB As Workbook, データWS As Worksheet, 対象行 As Long, シート名 As String)
 '//--------------------------------------------------------
 ' コピー先シートにデータをコピー
 '---------------------------------
    Dim 最終行 As Long

    シート確認作成処理 出力WB, シート名
    最終行 = 出力WB.Worksheets(シート名).Range(データ判定列 & Rows.Count).End(xlUp).Row + 1
    データWS.Rows(対象行 & ":" & 対象行 + コピー処理単位行数 - 1).Copy
    出力WB.Worksheets(シート名).Rows(最終行).Insert Shift:=xlDown
 End Sub

 '//--------------------------------------------------------
 Private Sub シート確認作成処理(出力WB As Workbook, シート名 As String)
 '//--------------------------------------------------------
 ' コピー先シートがあるかチェックしなければ作成
 '---------------------------------
    Dim 作業WS As Worksheet
    On Error Resume Next
    Set 作業WS = 出力WB.Worksheets(シート名)
    If 作業WS Is Nothing Then
        出力WB.Worksheets(作業シート名).Copy after:=出力WB.Worksheets(出力WB.Worksheets.Count)
        出力WB.Worksheets(出力WB.Worksheets.Count).Name = シート名
    End If
    On Error GoTo 0
 End Sub

 '//--------------------------------------------------------
 ' シートを名前順でソート
 '---------------------------------
 Private Sub シート並べ替え処理(出力WB As Workbook)
    Dim シート開始位置 As Long

    If オプション_新規ファイル作成 = True Then
        シート開始位置 = 1
    Else
        シート開始位置 = 2
    End If

    Dim i As Long
    Dim j As Long
    For i = シート開始位置 To 出力WB.Worksheets.Count - 1
        For j = i + 1 To 出力WB.Worksheets.Count
            If StrComp(出力WB.Worksheets(i).Name, 出力WB.Worksheets(j).Name) > 0 Then
                出力WB.Worksheets(j).Move before:=出力WB.Worksheets(i)
            End If
        Next
    Next
 End Sub


Mook-san有難う御座いました。頂いたヒントで別FileでWorkするよう改良が出来ました。
初心者なので理解が出来ていないところが多いので、勉強します。
(Toshi)

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.