人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

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 岩手 ナット

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

●質問者: anim130M
●カテゴリ:ビジネス・経営 コンピュータ
✍キーワード:Excel xls □□□ イメージ コピー
○ 状態 :終了
└ 回答数 : 4/4件

▽最新の回答へ

1 ● あっちゃん
●0ポイント

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


2 ● きゃづみぃ
●0ポイント

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

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

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

◎質問者からの返答

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

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

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


3 ● Mook
●150ポイント

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

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


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

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

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

これを無視して上書きしてよければ、上書き保存確認 を 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
◎質問者からの返答

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

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


4 ● きゃづみぃ
●1000ポイント ベストアンサー
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:\ です。

◎質問者からの返答

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

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

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ