Excelのマクロに関する質問です。良い回答は、200~1000ポイント差し上げます。

①「機器一覧.xls」オートフィルタで抽出したデータ分のファイルを作成
 このとき、ファイル作成は原書「部品管理_○○○店」をコピー
 ※抽出店舗は、70店舗位あります。
②その作成したファイル例「部品管理_横浜店,xls」に、「機器一覧.xls」から抽出したデータを例「部品管理_横浜店,xls」にシート挿入

【機器一覧.xls】
3 機器   店舗  科目  
4 55-110  岩手  ネジ  
5 54-001  岩手  ナット
6 56-086  横浜  電源
7 51-876  静岡  リング


□□□入力後イメージ□□□
例【部品管理_横浜店.xls】機器一覧シート
4 56-086  横浜  電源

例【部品管理_岩手店.xls】機器一覧シート
4 55-110  岩手  ネジ  
5 54-001  岩手  ナット

マクロでの回答は、ソースも記述願います。
どうか宜しくお願いします。

回答の条件
  • 1人10回まで
  • 登録:2011/07/17 01:39:04
  • 終了:2011/07/17 23:05:25

ベストアンサー

id:taknt No.4

きゃづみぃ回答回数13539ベストアンサー獲得回数11982011/07/17 19:25:06

ポイント1000pt
Sub main()

If Range("A3") = "" Then Exit Sub
Dim b() As String
Dim oWbk As Workbook
ReDim b(0)

e = Range("A3").End(xlDown).Row
m = ActiveSheet.Name
m2 = "c:\部品管理_○○○店.xls"

For a = 4 To e
    '作成チェック
    f = 0
    tenpo = Cells(a, "B")
    For c = 0 To UBound(b)
        If b(c) = tenpo Then
            f = 1
            Exit For
         End If
    Next c
    
    If f = 0 Then
        '作成
        ReDim b(UBound(b) + 1)
        b(UBound(b) - 1) = tenpo
        Workbooks.Open m2
        m3 = ActiveWorkbook.Sheets.Count
        ThisWorkbook.Sheets(m).Copy after:=ActiveWorkbook.Sheets(m3)
        m4 = ActiveWorkbook.ActiveSheet.Name

        d = "c:\部品管理_" + tenpo + "店.xls"
        
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs d
        
        For g = e To 4 Step -1
            If ActiveWorkbook.Sheets(m4).Cells(g, "B") <> tenpo Then
                ActiveWorkbook.Sheets(m4).Rows(g).Delete Shift:=xlUp
            End If
        Next g
        ActiveWorkbook.Close True
        Application.DisplayAlerts = True
    End If

Next a
End Sub

実行中は キーボードを触らないでください。

ブックを選択すると エラーになる恐れがあります。

なお 原書「部品管理_○○○店」は c:\ に置いてください。

作成されるのも c:\ です。

id:anim130M

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

望み通りのものが出力されました。ありがとうございました。

2011/07/17 23:03:34

その他の回答(3件)

id:a963 No.1

あっちゃん回答回数171ベストアンサー獲得回数162011/07/17 06:33:22

http://www.meta-proj.jp/metaproj2010.pdf


http://www.hiroyuki.tank.jp/soft/macro/mokuji.htm


http://exmcro.pasoconshigoto.com/


http://oshiete1.watch.impress.co.jp/qa6725649.html



http://search.yahoo.co.jp/search?fr=slv1-tbtop&p=Excel%E3%81%AE%E3%83%9E%E3%82%AF%E3%83%AD%E8%AA%AC%E6%98%8E%E6%9B%B8&ei=UTF-8



http://www.google.co.jp/search?sourceid=navclient&hl=ja&ie=UTF-8&rlz=1T4GFRE_jaJP360JP360&q=Excel%e3%81%ae%e3%83%9e%e3%82%af%e3%83%ad+%e2%91%a0%e3%80%8c%e6%a9%9f%e5%99%a8%e4%b8%80%e8%a6%a7.xls%e3%80%8d%e3%82%aa%e3%83%bc%e3%83%88%e3%83%95%e3%82%a3%e3%83%ab%e3%82%bf%e3%81%a7%e6%8a%bd%e5%87%ba%e3%81%97%e3%81%9f%e3%83%87%e3%83%bc%e3%82%bf%e5%88%86%e3%81%ae%e3%83%95%e3%82%a1%e3%82%a4%e3%83%ab%e3%82%92%e4%bd%9c%e6%88%90+%e3%80%80%e3%81%93%e3%81%ae%e3%81%a8%e3%81%8d%e3%80%81%e3%83%95%e3%82%a1%e3%82%a4%e3%83%ab%e4%bd%9c%e6%88%90%e3%81%af%e5%8e%9f%e6%9b%b8%e3%80%8c%e9%83%a8%e5%93%81%e7%ae%a1%e7%90%86_%e2%97%8b%e2%97%8b%e2%97%8b%e5%ba%97%e3%80%8d%e3%82%92%e3%82%b3%e3%83%94%e3%83%bc+%e3%80%80%e2%80%bb%e6%8a%bd%e5%87%ba%e5%ba%97%e8%88%97%e3%81%af%e3%80%8170%e5%ba%97%e8%88%97%e4%bd%8d%e3%81%82%e3%82%8a%e3%81%be%e3%81%99%e3%80%82+%e2%91%a1%e3%81%9d%e3%81%ae%e4%bd%9c%e6%88%90%e3%81%97%e3%81%9f%e3%83%95%e3%82%a1%e3%82%a4%e3%83%ab%e4%be%8b%e3%80%8c%e9%83%a8%e5%93%81%e7%ae%a1%e7%90%86_%e6%a8%aa%e6%b5%9c%e5%ba%97%2cxls%e3%80%8d%e3%81%ab%e3%80%81%e3%80%8c%e6%a9%9f%e5%99%a8%e4%b8%80%e8%a6%a7.xls%e3%80%8d%e3%81%8b%e3%82%89%e6%8a%bd%e5%87%ba%e3%81%97%e3%81%9f%e3%83%87%e3%83%bc%e3%82%bf%e3%82%92%e4%be%8b%e3%80%8c%e9%83%a8%e5%93%81%e7%ae%a1%e7%90%86_%e6%a8%aa%e6%b5%9c%e5%ba%97%2cxls%e3%80%8d%e3%81%ab%e3%82%b7%e3%83%bc%e3%83%88%e6%8c%bf%e5%85%a5

id:taknt No.2

きゃづみぃ回答回数13539ベストアンサー獲得回数11982011/07/17 09:01:08

マクロは 標準モジュールにおいて 実行してください。

シートコピーをしているため シートにマクロを入れておくとそのまま コピーされてしまいます。

Sub main()

If Range("A3") = "" Then Exit Sub
Dim b() As String
Dim oWbk As Workbook
ReDim b(0)

e = Range("A3").End(xlDown).Row

For a = 4 To e
    '作成チェック
    f = 0
    tenpo = Cells(a, "B")
    For c = 0 To UBound(b)
        If b(c) = tenpo Then
            f = 1
            Exit For
         End If
    Next c
    
    If f = 0 Then
        '作成
        ReDim b(UBound(b) + 1)
        b(UBound(b) - 1) = tenpo

        ActiveSheet.Copy
        d = "部品管理_" + tenpo + "店.xls"
        On Error GoTo syuryou
        
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs d
        
        For g = e To 4 Step -1
            If Workbooks(d).Sheets(1).Cells(g, "B") <> tenpo Then
                Workbooks(d).Sheets(1).Rows(g).Delete Shift:=xlUp
            End If
        Next g
        ActiveWorkbook.Close True
        Application.DisplayAlerts = True
    End If

Next a
End
syuryou:
MsgBox ("最初に作成したファイルを削除してから実行してください")
End Sub

id:anim130M

>このとき、ファイル作成は原書「部品管理_○○○店」をコピー

原書「部品管理_○○○店」の指定は何処で行えばよろしいでしょうか?

テスト実行したのですが、シートコピーでファイル作成されたところで、ループ状態に入りデータが抽出されていない状態でありました。

2011/07/17 15:14:05
id:Mook No.3

Mook回答回数1312ベストアンサー獲得回数3912011/07/17 18:28:51

ポイント150pt

細かい仕様がわからないので、仕様間違いもあるかもしれませんが、

理解できた範囲で作成してみました。


最初に「部品管理_○○○店」を聞かれるので、選択してください。

マクロを置いたファイルと同じフォルダに各店舗のファイルを保存しますが、

すでにあると、上書きしますかと確認が出ます。

これを無視して上書きしてよければ、上書き保存確認 を False にしてください。

'//--------------------------------------------------------
'// 処理:データを種類ごとにファイルに分類
'//--------------------------------------------------------
Option Explicit

'//--------------------------------------------------------
Const 上書き保存確認 = True    '--- 保存時に上書き保存を確認
Const checkRow = "B"           '--- 元データの分割判定を行う列
Const dataStartRow = 4         '--- データ開始行

'----------------------------------------------------
Sub 店舗別ファイル作成()
'----------------------------------------------------
'--- 処理するデータをコピー
    Dim srcWB As Workbook
    ThisWorkbook.Worksheets(1).Copy
    Set srcWB = ActiveWorkbook
    
    Dim srcWS As Worksheet
    Set srcWS = srcWB.Worksheets(1)
    
'--- テンプレートファイルを選択
    Dim tmpWorkBookPath As Variant
    tmpWorkBookPath = Application.GetOpenFilename( _
             FileFilter:="エクセルファイル(*.xls),*.xls" _
           , FilterIndex:=1 _
           , Title:="テンプレートファイル選択" _
           , MultiSelect:=False)

    If tmpWorkBookPath = False Then
        MsgBox "ファイルが選択されませんでした。"
        Exit Sub
    End If
    
'--- データ処理
    Dim lastRow As Long
    lastRow = srcWS.Cells(Rows.Count, checkRow).End(xlUp).Row
    
    Dim shopWB As Workbook
    Dim shopWS As Worksheet
    Dim shopRow As Long
    Dim srcRow As Long
    Dim shopName As String
'--- データが残っている間処理
    Do While Application.WorksheetFunction.CountA(srcWS.Range("B4").Resize(lastRow - 4, 1)) > 0
        shopName = srcWS.Range("B4").Value
        Set shopWB = Workbooks.Open(tmpWorkBookPath)
        Set shopWS = shopWB.Worksheets(1)
        shopRow = dataStartRow
        For srcRow = dataStartRow To lastRow
            If srcWS.Cells(srcRow, "B").Value = shopName Then
                shopWS.Cells(shopRow, "A").Value = srcWS.Cells(srcRow, "A").Value
                shopWS.Cells(shopRow, "B").Value = srcWS.Cells(srcRow, "B").Value
                shopWS.Cells(shopRow, "C").Value = srcWS.Cells(srcRow, "C").Value
                srcWS.Cells(srcRow, "B").EntireRow.ClearContents
                shopRow = shopRow + 1
            End If
        Next
        
        shopWS.Name = "機器一覧シート"
        If 上書き保存確認 = False Then Application.DisplayAlerts = False
        shopWB.SaveAs ThisWorkbook.Path & "\部品管理_" & shopName & "店.xls"
        shopWB.Close
        Application.DisplayAlerts = True
    
        Range("B4").Resize(lastRow - 3, 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Loop
    Application.DisplayAlerts = False
    srcWB.Close
    Application.DisplayAlerts = True
End Sub
id:anim130M

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

今回は「taknt」様を採用させていただきました。

2011/07/17 23:02:48
id:taknt No.4

きゃづみぃ回答回数13539ベストアンサー獲得回数11982011/07/17 19:25:06ここでベストアンサー

ポイント1000pt
Sub main()

If Range("A3") = "" Then Exit Sub
Dim b() As String
Dim oWbk As Workbook
ReDim b(0)

e = Range("A3").End(xlDown).Row
m = ActiveSheet.Name
m2 = "c:\部品管理_○○○店.xls"

For a = 4 To e
    '作成チェック
    f = 0
    tenpo = Cells(a, "B")
    For c = 0 To UBound(b)
        If b(c) = tenpo Then
            f = 1
            Exit For
         End If
    Next c
    
    If f = 0 Then
        '作成
        ReDim b(UBound(b) + 1)
        b(UBound(b) - 1) = tenpo
        Workbooks.Open m2
        m3 = ActiveWorkbook.Sheets.Count
        ThisWorkbook.Sheets(m).Copy after:=ActiveWorkbook.Sheets(m3)
        m4 = ActiveWorkbook.ActiveSheet.Name

        d = "c:\部品管理_" + tenpo + "店.xls"
        
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs d
        
        For g = e To 4 Step -1
            If ActiveWorkbook.Sheets(m4).Cells(g, "B") <> tenpo Then
                ActiveWorkbook.Sheets(m4).Rows(g).Delete Shift:=xlUp
            End If
        Next g
        ActiveWorkbook.Close True
        Application.DisplayAlerts = True
    End If

Next a
End Sub

実行中は キーボードを触らないでください。

ブックを選択すると エラーになる恐れがあります。

なお 原書「部品管理_○○○店」は c:\ に置いてください。

作成されるのも c:\ です。

id:anim130M

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

望み通りのものが出力されました。ありがとうございました。

2011/07/17 23:03:34
  • id:taknt
    >ファイル作成は原書「部品管理_○○○店」をコピー

    すみません、コピーじゃなくて新規で作成してました。

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

トラックバック

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

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

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