[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『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)
それで実際にやってみたのですが、
コンパイルエラー:修正候補:名前付き引数
と出て、Typeが反転して、文全体が赤字になってしまいます。
自分でも調べてみたり、いじってみたりしたのですが、うまくいきません。
お力お借りできたら嬉しいです。
よろしくお願いいたします。
（TRO）
あっ、ごめんなさい。
名前付き引数は Type= ではなく Type:= です。 =の前に:を追加して試してみてください。 (Mook)
テンプレートファイルのパスは多分あっていて、
テンプレート自体はある程度適応されているようです。
これは何が問題なんでしょう？
（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)処理先ファイルの指定 '// 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)
上のコードは自ファイルを処理するようにしていますので、ThisWorkbook と書かれている部分を処理する ブックに変更してあげれば出来るかと思います。
処理するファイルをどう指定するかは作り方しだいですが、最初に処理用のブックオブジェクトや シートオブジェクトの変数を用意し、それを ThisWorkbook と ThisWorkbook.WorkSheets(masterSheetName） の代りに全体で使うようにしてみてはどうでしょうか。 (Mook)
だいぶ古い板ですが、他ファイルを処理する機能追加版です。 他にも 65536 行以上を処理しようとすると（2003の頃はこんなことは無かったのですが）、 エラーになっていたので、修正しました。
ついでに、最近私の中のマイブームの日本語コード化しました。 (Mook)
'//-------------------------------------------------------- '// 処理：データを種類ごとにシートに分類 '//-------------------------------------------------------- '// 処理するファイル内にマクロを置いて実行してください。 '//-------------------------------------------------------- Option Explicit
'//-------------------------------------------------------- '// ファイルに併せて設定 '//-------------------------------------------------------- Const データシート名 = "Data" '--- 元データシート名 Const 分類列 = "C" '--- 元データの分割判定を行う列 Const データ判定列 = "E" '--- 各シートの最終列を判定する列 Const コピー処理単位行数 = 1 '--- コピー行単位 Const データ開始行 = 3 '--- 各シートのデータ開始行（ヘッダ行＋１）
'//-------------------------------------------------------- '// オプション '//--------------------------------------------------------
'//------------------------- '// 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
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.