[[20100321005104]]　『20080522180917のはとさんの質問の改造』（にゃごまる）　ページの最後に飛ぶ

『20080522180917のはとさんの質問の改造』（にゃごまる）

はとさんの質問の、回答LISTを実行すると、bookが追加されますが
同じbookの中に作るにはどうしたらいいでしょうか?

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

追加です。
そのときのMOOKさんの回答です。

 Option Explicit

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

 Const masterSheetName = "ALL"   '--- 元データシート名
 Const checkRow = "E"            '--- 元データの分割判定を行う列
 Const checkLastRow = "I"        '--- 各シートの最終列を判定する列
 Const rowUnitSize = 2           '--- コピー行単位
 Const dataStartLine = 3         '---  各シートのデータ開始行（ヘッダ行＋１）

 '=================================
 Sub Grouping()
 '=================================
    Dim i&, lastRow
    Dim dstWB As Workbook

    Application.ScreenUpdating = False
    With ThisWorkbook.Worksheets(masterSheetName)
        lastRow = .Range(checkRow & Rows.Count).End(xlUp).Row
        .Copy
        Set dstWB = ActiveWorkbook
        dstWB.Worksheets(masterSheetName).Name = tmpSheetName
        dstWB.Worksheets(tmpSheetName).Rows(dataStartLine & ":" & Rows.Count).Clear

        For i = dataStartLine To lastRow
            If .Cells(i, checkRow).Value <> "" Then
                AddLine dstWB, i, .Cells(i, checkRow).Value
            End If
        Next
    End With
    Application.DisplayAlerts = False
    dstWB.Worksheets(tmpSheetName).Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
 End Sub

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

    checkAndMake dstWB, sheetName
    lastLine = dstWB.Worksheets(sheetName).Range(checkLastRow & 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

 '=================================
 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
 (Mook)

[[20080522180917]]　『マクロ：種別毎に各シートへ転記（振り分け）した』（はと）

 懐かしいコードですね。
 最初の方の
        .Copy
        Set dstWB = ActiveWorkbook
        dstWB.Worksheets(masterSheetName).Name = tmpSheetName
 を
        .Copy after:=Worksheets(Worksheets.Count)
        Set dstWB = ThisWorkbook
        dstWB.Worksheets(Worksheets.Count).Name = tmpSheetName
 に変えれば、自ブック内での処理になると思います。
 (Mook)

早速の回答ありがとうございました。
VBAは、まだちょっとかじったばかりで、お恥ずかしい質問してすみませんでした。
是を参考にがんばってみます。

こんばんわ
もう1つ問題が出てしまいました。
このプロで、1回目の実行結果は、よいのですが、何度も実行すると、データが種別シートに
繰り返し足されてしまいます。できれば処理前に各シートを削除後、実行したいのですが。
または、こちらは難しくなると思いますが、繰り返し実行したときに同じデータは、表示しない様にしたいのですが。
すみませんよろしくお願いします

 このような重複を避けるために、オリジナルでは新規ブックに作成するように
 しています。
 ２番目以降のシートをすべて削除するなら、下記を処理の最初に実行します。
    Application.DisplayAlerts = False
    For w = 2 To Worksheets.Count
        ThisWorkbook.Worksheets(w).Delete
    Next
    Application.DisplayAlerts = True
 (Mook)

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

完成しました。
下記に改修してうまく動作できました。
ありがとうございました。

ii = Worksheets.Count

    For w = ii To 2 Step -1
        ThisWorkbook.Worksheets(w).Delete
    Next w

コメント返信：

[ 一覧(最新更新順) ]

[[20100321005104]] 『20080522180917のはとさんの質問の改造』（にゃごまる） ページの最後に飛ぶ

[[20100321005104]]　『20080522180917のはとさんの質問の改造』（にゃごまる）　ページの最後に飛ぶ