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

Excelのマクロに関する質問です。良い回答は、200?800ポイント差し上げます。
オートフィルタで抽出されたデータを各シートに振り分けて反映させたい。
?[機器一覧.xls]-[マスターファイル]シートを店舗名でオートフィルタ(手動)
?次に、抽出されたデータを[種類]・[科目]で振り分け

[機器一覧.xls]-[マスターファイル]シート
3 機器 店舗 種類 科目
4 55-110 岩手 小型
5 54-001 岩手 大型
6 56-086 横浜 機器
7 51-876 岩手 大型 機器

[機器一覧.xls]-[マスターファイル]シート
3 機器 店舗 種類 科目
4 55-110 岩手 小型
5 54-001 岩手 大型
7 51-876 岩手 大型 機器
※オートフィルターで抽出されたデータを各シートに反映

□□□実行後イメージ□□□
例.[機器一覧.xls]-[大型]シート
2 54-001
3 51-876
例.[機器一覧.xls]-[小型]シート
5 55-110
例.[機器一覧.xls]-[機器]シート
2 51-876
※各シートへの反映は、セル指定したい。

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

●質問者: anim130M
●カテゴリ:コンピュータ
✍キーワード:Excel xls □□□ イメージ セル
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● きゃづみぃ
●800ポイント ベストアンサー

フィルタをかけた状態で実行します。

セルは それぞれ 指定できますので 変更してください。


Sub main()
  'マスターファイルシートの開始位置
 s1 = 1
 
  '[大型]シートのセル指定 例 A列 2行目から
 s2 = "A"
 r2 = 2
 
  '[小型]シートのセル指定 例 A列 5行目から
 s3 = "A"
 r3 = 5
 
  '[機器]シートのセル指定 例 A列 2行目から
 s4 = "A"
 r4 = 2
 
 
 If Worksheets("マスターファイル").Cells(4, s1) = "" Then End
 
 For a = 4 To Worksheets("マスターファイル").Cells(4, s1).End(xlDown).Row
 If Not Worksheets("マスターファイル").Rows(a).Hidden Then
 If Worksheets("マスターファイル").Cells(a, s1 + 2) = "大型" Then
 Worksheets("大型").Cells(r2, s2) = Worksheets("マスターファイル").Cells(a, s1)
 r2 = r2 + 1
 End If
 
 If Worksheets("マスターファイル").Cells(a, s1 + 2) = "小型" Then
 Worksheets("小型").Cells(r3, s3) = Worksheets("マスターファイル").Cells(a, s1)
 r3 = r3 + 1
 End If
 
 If Worksheets("マスターファイル").Cells(a, s1 + 3) = "機器" Then
 Worksheets("機器").Cells(r4, s4) = Worksheets("マスターファイル").Cells(a, s1)
 r4 = r4 + 1
 End If
 
 End If
 
 
 Next a

End Sub

2 ● ジュードマテイス
●0ポイント

これがお勧めです

Sub main()

'マスターファイルシートの開始位置

s1 = 1

'[大型]シートのセル指定 例 A列 2行目から

s2 = "A"

r2 = 2

'[小型]シートのセル指定 例 A列 5行目から

s3 = "A"

r3 = 5

'[機器]シートのセル指定 例 A列 2行目から

s4 = "A"

r4 = 2

If Worksheets("マスターファイル").Cells(4, s1) = "" Then End

For a = 4 To Worksheets("マスターファイル").Cells(4, s1).End(xlDown).Row

If Not Worksheets("マスターファイル").Rows(a).Hidden Then

If Worksheets("マスターファイル").Cells(a, s1 + 2) = "大型" Then

Worksheets("大型").Cells(r2, s2) = Worksheets("マスターファイル").Cells(a, s1)

r2 = r2 + 1

End If

If Worksheets("マスターファイル").Cells(a, s1 + 2) = "小型" Then

Worksheets("小型").Cells(r3, s3) = Worksheets("マスターファイル").Cells(a, s1)

r3 = r3 + 1

End If

If Worksheets("マスターファイル").Cells(a, s1 + 3) = "機器" Then

Worksheets("機器").Cells(r4, s4) = Worksheets("マスターファイル").Cells(a, s1)

r4 = r4 + 1

です


3 ● Mook
●200ポイント

作成したいシートは、本当に「大型」「小型」「機器」だけなのでしょうか。

[種類]・[科目]に応じて自動でシート名を作成する例です。


実行すると追記するようにしていますが、シートを再作成したい場合は

Const appendMode = False

に変更してください。

 '//--------------------------------------------------------
 '// 処理:データを種類ごとにシートに分類
 '//--------------------------------------------------------
 '// 処理するファイル内にマクロを置いて実行してください。
 '//--------------------------------------------------------
 Option Explicit

 '//--------------------------------------------------------
 '// ファイルに併せて設定
 '//--------------------------------------------------------
 Const masterSheetName = "マスターファイル"  '--- 元データシート名
 Const dataStartLine = 4  '--- 各シートのデータ開始行(ヘッダ行+1)
 
 '//-------------------------
 '// 追記モードの指定
 '// True ・・・ データを追記 ★注意:2回実行すると同じものが追加されます
 '// False ・・・ データ再登録 ★注意:Master シート以外をすべて再作成します
 Const appendMode = True

 '//--------------------------------------------------------
 Sub 種別分類()
 '//--------------------------------------------------------
 Dim i&, lastRow
 Dim dstWB As Workbook
 Dim ws As Worksheet

  '//--- 開始処理
 Application.ScreenUpdating = False

 Dim r As Range
 With ThisWorkbook.Worksheets(masterSheetName)
 lastRow = .Range("A" & Rows.Count).End(xlUp).Row
 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
 For Each r In Range("C4").Resize(lastRow, 1).SpecialCells(xlVisible)
 If .Cells(r.Row, "C").Value <> "" Then
 AddLine dstWB, r.Row, "種別-" & .Cells(r.Row, "C").Value
 End If
 If .Cells(r.Row, "D").Value <> "" Then
 AddLine dstWB, r.Row, "科目-" & .Cells(r.Row, "D").Value
 End If
 Next
 End With

  '//--- 終了処理
 Application.ScreenUpdating = True

  '//--- 表示位置の調整
 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("A" & Rows.Count).End(xlUp).Row + 1
 dstWB.Worksheets(sheetName).Cells(lastLine, "A").Value _
 = ThisWorkbook.Worksheets(masterSheetName).Cells(lineNum, "A").Value
 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.Add After:=dstWB.Worksheets(dstWB.Worksheets.Count)
 dstWB.Worksheets(dstWB.Worksheets.Count).Name = sheetName
 dstWB.Worksheets(sheetName).Range("A1").Value = "機器"
 End If
 On Error GoTo 0
 End Sub

同様の要望はEXCELを使っている方には多いようです。

別の掲示板に回答したものですが、

http://www.excel.studio-kazu.jp/kw/20110301184111.html

を改良してみました。

◎質問者からの返答

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

関連質問


●質問をもっと探す●



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