①「機器一覧.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 岩手 ナット
マクロでの回答は、ソースも記述願います。
どうか宜しくお願いします。
No.4
13539
1198
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:\ です。
No.1
17116
No.2
135391198
マクロは 標準モジュールにおいて 実行してください。
シートコピーをしているため シートにマクロを入れておくとそのまま コピーされてしまいます。
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
>このとき、ファイル作成は原書「部品管理_○○○店」をコピー
原書「部品管理_○○○店」の指定は何処で行えばよろしいでしょうか？
テスト実行したのですが、シートコピーでファイル作成されたところで、ループ状態に入りデータが抽出されていない状態でありました。
No.3
1314393
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
回答ありがとうございました。
今回は「taknt」様を採用させていただきました。
No.4
135391198
ここでベストアンサー
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:\ です。
回答ありがとうございました。
望み通りのものが出力されました。ありがとうございました。
きゃづみぃ
2011/07/17 18:10:20
4
2
1
2
2
31
30
回答ありがとうございました。
望み通りのものが出力されました。ありがとうございました。