• はてなアカウントでログイン
• 無料ユーザー登録

ベストアンサー

• きゃづみぃ2011/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
  

  スター

その他の回答

• ジュードマテイス2011/07/20 16:29:20

  0pt

  これがお勧めです

  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

  です

  スター

Mook2011/07/20 23:55:26

満足200pt

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

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




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

Const appendMode = False

に変更してください。

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

 '//--------------------------------------------------------
 '// ファイルに併せて設定
 '//--------------------------------------------------------
 Const masterSheetName = "マスターファイル"   '--- 元データシート名
 Const dataStartLine = 4         '---  各シートのデータ開始行（ヘッダ行＋１）
 
 '//-------------------------
 '// 追記モードの指定
 '// 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

を改良してみました。

スター

• anim130M 2011/07/22 21:26:49

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

• その他の回答を読む

この質問へのコメント

• きゃづみぃ2011/07/20 11:44:29
  オートフィルタってのは 見た目だけの問題なので、プログラム上は あまり関係ない。
  
  
• godabin2011/07/22 18:23:13
  回答No.2って、回答No.1の内容の　コピペなんじゃないの？
  
  

質問の情報

登録日時

2011-07-20 11:40:05

終了日時

2011-07-22 21:27:43

回答条件

1人10回まで

この質問のカテゴリ

• コンピュータ

この質問に含まれるキーワード

人気の質問

• 音楽のドレミですが、日本では、音階がドレミで、音名はハニホです。ドイツではCDE、英米でCDE、そして、イ…匿名質問者1211日前
• マンガ展のリアルサイン会について マンガ展にて、とある漫画家さんのリアルサイン会イベントに当選させて…匿名質問者215時間前
• マンガ展のリアルサイン会について マンガ展にて、とある漫画家さんのリアルサイン会イベントに当選させて…匿名質問者15時間前
• フェンス用のフェイクグリーンはどこがおすすめですか。フェンスやバルコニーで、視線除けに使うそうです。…匿名質問者116時間前
• プロ野球　琉球ブルーオーシャンズ　2025年よりファームへ参入するのはどれですか？…ren99082715時間前

メニュー

• 質問一覧
• カテゴリ一覧
• 無料ユーザー登録
• 人力検索はてなトップ

PC版

• お問い合わせ
• ヘルプ
• お知らせ
• はてなトップ