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
※各シートへの反映は、セル指定したい。

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

回答の条件
  • 1人10回まで
  • 13歳以上
  • 登録:2011/07/20 11:40:05
  • 終了:2011/07/22 21:27:43

ベストアンサー

id:taknt No.1

きゃづみぃ回答回数13538ベストアンサー獲得回数11982011/07/20 12:23:41

ポイント800pt

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

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


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件)

id:taknt No.1

きゃづみぃ回答回数13538ベストアンサー獲得回数11982011/07/20 12:23:41ここでベストアンサー

ポイント800pt

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

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


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
id:qweertyuiop No.2

ジュードマテイス回答回数10ベストアンサー獲得回数02011/07/20 16:29:20

これがお勧めです

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

です

id:Mook No.3

Mook回答回数1312ベストアンサー獲得回数3912011/07/20 23:55:26

ポイント200pt

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

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


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

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

を改良してみました。

id:anim130M

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

2011/07/22 21:26:49

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

トラックバック

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

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

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