EXCEL　必要な条件だけを別シートに自動コピーさせる方法

Question

手間がかかるタイピングを簡単にさせるため、次のようか事ができないかと考えております。EXCELは中級クラスです。VBAなどを使う場合は、お手数ではございますが、超わかりやすくご回答頂ければ幸いです。

”シート１”に下記のような入力をすると、
”シート東京”には、東京の行だけがコピーされ、
”シート大阪”には、大阪の行だけがコピーされる。

販売　場所　　

１月　東京　　　
１月　大阪　　
１月　沖縄　　
２月　東京　　
２月　大阪　　
２月　沖縄

KenKen_SP · Accepted Answer

＞シート１のデータを追加入力しても、「東京」などの自動的に作成されたシートには自動反映されないんですか？
＞反映させるためには、どうしたらいいですか？

方法は2つあります。

・一度「東京」などのデータ入力シート以外を削除し、再度マクロで再構築
・コードをカスタマイズして、データ範囲の取得方法を変更する

前者を「前提」としてコーディングしましたので、前者で対応して下さい。

また、#9でも書きましたが「データをあるキーによりシートに仕訳したい」という要望をよく見かけます。したがって、mintanさん以外の方が今回と同様な事例にあった場合でも対応できよう汎用性を考慮しました。お役に立てればうれしいです。


＞...マクロってなんですか？(^_^;)

このように定型的な作業を自動化するため、あるいはEXCELの機能をユーザー好みに強化するためのツールです。

matsu_jun · Answer

#3、#8のmatsu_junです。
うーん、こちらでは動作したのですが、恐らく途中でエラーを起こして終了したものと思われます。私の方法では途中でエラーを起こすとその後の処理をすっ飛ばして終了してしまうようになっていますので。
ただ、#9のKenKen_SPさんのものが素晴らしいデキで、私自身も感心しきりのものですので、そちらが成功したらそちらでされるのがよろしいかと。
お力になれずスミマセン。いつかVBAを勉強されて、私の不出来なソースをご自身で修正されることのできる日が来ることをお祈りいたします。ではこれからも頑張ってください。

KenKen_SP · Answer

#1,#6,#9です。

補足ですが、シート「東京」などを予め用意しておく必要はありません。データが入力されたシート1つのみ状態で、マクロを実行して下さい。

＜手順＞
1.　[Alt]+[F11]キーでVisual Basic Editor起動
2.　[挿入]-[標準モジュール]クリック
3.　開いたウインドウに#9の【以下コード（標準モジュール）】の次行から終わりまでをコピー＆貼り付け
4.　Visual Basic Editorを閉じる

その後、データのあるシートを選択し、

EXCELの[ツール]-[マクロ]-[マクロ]で SplitSh を実行します。

KenKen_SP · Answer

#1,#6です。

本ご質問のような「データをあるキーによりシートに分散させたい」という要望は様々な場面でよく見かけますので、VBAでコードを書いてみました。少々長いコードですから、コードの内容については細かな解説はできませんが、是非お試し下さい。

本コードの特徴は、

・データを配列で処理しているため、比較的高速
・処理の大半を関数にしてあるので、カスタマイズが容易
・シート名やデータ範囲をユーザーが直接指定できるため、コードの変更不要

にあります。テストデータでは2000件を2～3秒で処理終了しました。
なお、テスト環境は WinXPpro + P4CPU 2.4G + 512M Mem + Excel2002 です。

マクロ　SplitSh　を実行して下さい。


【以下コード（標準モジュール）】


Option Explicit
Option Base 1

Public Sub SplitSh()

　　Dim rngMidasi As Range, rngKeyCol As Range
　　Dim DataRng As Range, rngCell As Range
　　Dim Buf As Variant
　　Dim newSh As Worksheet
　　Dim strSheetName As String
　　Dim strMes As String
　　Dim Res As Integer, ShNameCol As Integer

　　'最大シート追加許可数設定
　　Const MaxShCount As Integer = 200

SetDataArea:

　　'データ範囲取得等----------------------------------------------------------
　　Range("A1").Select
　　'見出し行
　　On Error Resume Next
　　Set rngMidasi = Application.InputBox( _
　　　　Prompt:="データ見出しの 「セル範囲」 を選択して下さい", Type:=8)
　　If rngMidasi Is Nothing Then GoTo ExitHandler
　　If InStr(1, rngMidasi.Address, ",") > 0 Then
　　　　MsgBox "複数の範囲には対応できません", vbCritical, "中止"
　　　　GoTo SetDataArea
　　End If
　　'データ範囲定義
　　With rngMidasi
　　　　Set DataRng = .Offset(.Rows.Count).Resize _
　　　　　　(.CurrentRegion.Rows.Count - .Rows.Count)
　　End With
　　DataRng.Select
　　'シート仕訳のキーとなる列を定義
　　Set rngKeyCol = Application.InputBox( _
　　　　Prompt:="データ範囲を選択しました。" & vbCrLf & vbCrLf & _
　　　　　　　　"次に、シート仕訳のキーとなる列全体を選択して下さい", Type:=8)
　　If rngKeyCol Is Nothing Then GoTo ExitHandler
　　DataRng.Columns(rngKeyCol.Column).Select
　　On Error GoTo 0

　　'転記先シート名として不適格な文字がないか----------------------------------
　　For Each rngCell In Selection
　　　　If InvalidSheetName(rngCell.Text) Or _
　　　　　　IsEmpty(rngCell) Then
　　　　　　strMes = ""
　　　　　　strMes = strMes & "シート名には、以下の制限があります" & vbCrLf
　　　　　　strMes = strMes & "・半角で数えて31文字以内です" & vbCrLf
　　　　　　strMes = strMes & "・特殊記号（;:\/?*[]）は使えません" & vbCrLf
　　　　　　strMes = strMes & "・空を指定できません" & vbCrLf & vbCrLf
　　　　　　strMes = strMes & "エラーセル：" & rngCell.Address
　　　　　　MsgBox strMes, vbCritical, "中止：シート名として不適格です"
　　　　　　Exit Sub
　　　　End If
　　Next rngCell
　　
　　'転記開始------------------------------------------------------------------
　　Application.ScreenUpdating = False
　　For Each rngCell In Selection
　　　　'転記先シート名とデータを取得
　　　　strSheetName = rngCell.Text
　　　　Buf = Intersect(DataRng, DataRng.Parent.Rows(rngCell.Row))
　　　　'転記開始
　　　　If Not DataPost(strSheetName, Buf) Then
　　　　　　'転記先シートが無いため失敗の場合
　　　　　　With ActiveWorkbook
　　　　　　　　'シートを末尾に追加
　　　　　　　　If .Sheets.Count >= MaxShCount Then
　　　　　　　　　　MsgBox "シート数が多すぎます", vbCritical, "中止"
　　　　　　　　　　GoTo ExitHandler
　　　　　　　　End If
　　　　　　　　Set newSh = .Sheets.Add( _
　　　　　　　　After:=.Sheets(.Sheets.Count))
　　　　　　　　'シート名変更
　　　　　　　　newSh.Name = strSheetName
　　　　　　　　'見出し複写とデータの再転記
　　　　　　　　With rngMidasi
　　　　　　　　　　newSh.Range("A1").Resize( _
　　　　　　　　　　　　.Rows.Count, rngMidasi.Columns.Count) _
　　　　　　　　　　　　= rngMidasi.Value
　　　　　　　　End With
　　　　　　　　DataPost strSheetName, Buf
　　　　　　　　Set newSh = Nothing
　　　　　　End With
　　　　End If
　　Next rngCell
　　
　　rngMidasi.Parent.Select
　　Application.ScreenUpdating = True
　　MsgBox "終了しました", vbInformation
　　
ExitHandler:
　　Set rngMidasi = Nothing
　　Set rngKeyCol = Nothing
　　Set DataRng = Nothing
　　Exit Sub

End Sub

'指定ワークシートにデータ転記を行う
Public Function DataPost( _
　　strSheetName$, aryBuf As Variant) As Boolean
　　
　　Dim TargetRow As Long
　　
　　On Error GoTo ErrorHandler
　　DataPost = False
　　TargetRow = GetRownum(strSheetName, 1)
　　
　　If TargetRow And IsArray(aryBuf) Then
　　　　ActiveWorkbook.Sheets(strSheetName). _
　　　　Cells(TargetRow, 1).Resize(, UBound(aryBuf, 2)) _
　　　　= aryBuf
　　　　DataPost = True
　　End If

ExitHandler:
　　Exit Function
ErrorHandler:
　　DataPost = False
　　Resume ExitHandler

End Function

'引数で渡されるシートのデータ終端行の次行番号を返す
Public Function GetRownum( _
　　strSheetName$, ColumnNumber%) As Long

　　GetRownum = 0
　　If ExistSheet(strSheetName) Then
　　　　With ActiveWorkbook.Sheets(strSheetName)
　　　　　　GetRownum = .Cells(65536, 1).End(xlUp).Row + 1
　　　　End With
　　End If

End Function

'引数で渡されるシート名が既に存在するかを返す
Public Function ExistSheet(strSheetName$) As Boolean

　　Dim Sh As Worksheet
　　
　　ExistSheet = False
　　For Each Sh In ActiveWorkbook.Worksheets
　　　　If Sh.Name = strSheetName Then
　　　　　　ExistSheet = True
　　　　　　Exit For
　　　　End If
　　Next Sh

End Function

'シート名に使えない文字が含まれるか
Public Function InvalidSheetName(strParam$) As Boolean

　　Dim BadChar As String
　　Dim I As Integer
　　
　　BadChar = ":\/?*[]"
　　InvalidSheetName = False
　　
　　If LenB(strParam) > 31 Or _
　　　　strParam = Chr(32) Then
　　　　InvalidSheetName = True
　　　　Exit Function
　　End If
　　For I = 1 To Len(BadChar)
　　　　If InStr(1, strParam, Mid(BadChar, I, 1), _
　　　　　　vbTextCompare) > 0 Then
　　　　　　InvalidSheetName = True
　　　　　　Exit For
　　　　End If
　　Next I

End Function

matsu_jun · Answer

#3のmatsu_junです。

> 4) Alt + F11 で、Visual Basic エディタを起動させる
この部分を以下のように操作し代えてください

4) Excelのメニューから「ツール(T)－マクロ(M)－マクロ(M)」でマクロウィンドウを表示させ、「シート整理」を選択した後、右の「編集(E)」をクリックする。
4.5) すると自動的にVisual Basic エディタが起動し、右側に
　Sub シート整理()
　'
　' シート整理 Macro
　' マクロ記録日 : 2005/2/20 ユーザー名 : ○○ ○○
　'

　'
　End Sub
と書かれた部分が表示されます。

ここを、5)の
'ここから----------------------------------------------------------
から
'ここまで----------------------------------------------------------
の部分にサクっと置き換えてやればOKです。

ここまでの操作には、A列とB列が埋まっていないことは関係ありません。
なおA列には「販売」、B列には「場所」が入っているものとして考えていまして、販売月だけが入力されていて場所が入力されていない行や、場所だけが入力されていて販売月だけが入力されている行があるとよろしくない。特に前者(販売月だけが入力されていて場所が入力されていない行がある)の状況だと、マクロの処理が途中で終了してしまいます。
その程度のことですので、ご心配ないよう。

macchan1 · Answer

＞すみません。わかりません。　エラー表示になります。

数式を入力後、配列数式とするためにCtrl+Shift+Enterで確定しているでしょうか?

＞シート１で入力している内容と、東京シートの関数入力先をもう一度お教えいただけますでしょうか？

Sheet1のA1に販売、A2以下に月、B1に場所B2以下に場所データが入っていることと、入力するセルは東京シートのA2セル（A1セルが項目名として）に入力します。

KenKen_SP · Answer

ほぼ自動で転記できるVBAコードを書いてます。
ただ、汎用的に使えるようにするため、コードを調整していますので、可能でしたら、もう少し時間を下さい。

macchan1 · Answer

＃4の補足です。

エラー処理はINDEXの行がリストの選択範囲を超えたときに起こりますので、IF関数で例えば以下のような数式を追加すれば表示されなくなります。

IF(ROW(A1)+SUMPRODUCT(((Sheet1!$B$1:$B$100<>"東京")*1))>100,"",元の式）

データ数が100を超える場合は数式のすべての100の数字を1000や10000などに適宜変更してください。

macchan1 · Answer

この程度の条件であれば、関数を工夫すれば、ほとんどの場合、希望の操作を行うことができます。
この場合は、配列数式で希望のデータを表示することができます。

販売月がSheet1のA列、場所がB列に入っている場合、シート東京のA2セルに以下の式を入力して、配列数式とするためにCtrl+Shift+Enterで確定します。
この数式を、右方向及び下方向にオートフィル(コピー）すれば希望のデータが表示されます。

=INDEX(Sheet1!$A$1:$C$100,SMALL((Sheet1!$B$1:$B$100="東京")*ROW($B$1:$B$100),ROW(A1)+SUMPRODUCT(((Sheet1!$B$1:$B$100<>"東京")*1))),COLUMN(A1))

なお、上記の関数はエラー処理していません。

matsu_jun · Answer

VBAを利用しない場合
1) 元データに対してオートフィルタをかける(データ(D)－フィルタ(F)－オートフィルタ(F))
2) B列から任意の場所を選択する
3) コピーしたい列を選択する
4) Ctrl + G (Ctrlを押しながらG)で「ジャンプ」ウィンドウを表示させる
5) 「ジャンプ」ウィンドウの「セル選択(S)」ボタンをクリックする
6) 「可視セル(Y)」を選択し、「OK」をクリックする
7) Ctrl + C で、選択されたデータをコピーする。
8) 目的のシートへ移動し、Ctrl + V でコピーしたデータを貼り付ける

VBAを利用する場合
1) どのシートを開いていてもよいので、メニューから「ツール(T)－マクロ(M)－新しいマクロの記録(R)」を選択する
2) マクロ名(M)を「シート整理」として、「OK」をクリックする
3) 何も記録させずにマクロの記録を終了する
4) Alt + F11 で、Visual Basic エディタを起動させる
5) 右側の
　Sub シート整理()
　'
　' シート整理 Macro
　' マクロ記録日 : 2005/2/20  ユーザー名 : ○○ ○○
　'

　'
　End Sub
と書かれた部分に、以下のソースを貼り付ける

'ここから--------------------------------------------------
Sub シート整理()
    Application.ScreenUpdating = False
    On Error GoTo ERRHD
    CLMNUM# = Worksheets("元データ").Cells(1, 256).End(xlUp).Column

'元データ以外のデータを削除します
    For Each Sh In Worksheets
        If Sh.Name <> "元データ" Then
            Sh.Cells.Delete
            For i# = 1 To CLMNUM
                Sh.Cells(1, i).Value = Worksheets("元データ").Cells(1, i).Value
            Next i
        End If
    Next Sh

'データをコピーします
    For i = 2 To Worksheets("元データ").Cells(65536, 1).End(xlUp).Row
        j# = 0
        For Each Sh In Worksheets
            If Sh.Name = Worksheets("元データ").Cells(i, 2).Value Then
                j = 1
                Exit For
            End If
        Next Sh
        If j = 0 Then '検索中の人のシートがない場合、新規に作成する。
            Worksheets.Add After:=Worksheets(Worksheets.Count)
            Worksheets(Worksheets.Count).Name = Worksheets("元データ").Cells(i, 2).Value
            For j = 1 To CLMNUM
                Worksheets(Worksheets.Count).Cells(1, j).Value = Worksheets("元データ").Cells(1, j).Value
            Next j
        End If
        For j = CLMNUM To 1 Step -1
            Worksheets(Worksheets("元データ").Cells(i, 2).Value). _
            Cells(Worksheets(Worksheets("元データ").Cells(i, 2).Value). _
            Cells(65536, 1).End(xlUp).Row + 1, j).Value = Worksheets("元データ").Cells(i, j).Value
        Next j
    Next i

'利用しなかった不要なシートを削除するか問い合わせます。
    DLTFLG# = MsgBox("利用しなかったシートを削除しますか?", vbYesNo, "確認")
    Application.DisplayAlerts = False
    For Each Sh In Worksheets
        If Sh.Cells(2, 1) = Empty And DLTFLG = 6 Then Sh.Delete
    Next Sh
    Application.DisplayAlerts = True
    
ERRHD:
    Application.ScreenUpdating = True
End Sub
'ここまで--------------------------------------------------

6) Visual Basic エディタを終了する

利用したい時は、Alt + F8キーでマクロの再生ウィンドウを開き、「シート整理」を選択して「実行(R)」ボタンをクリック

少し解説しますが、このマクロを利用するためには以下の条件が必要です。
1) A列、B列には全部埋めてください。空きがあるとこけます。
2) C列以降にデータが入っていてもOKです。それらもコピーします。
3) 1行目はタイトル行ですので、項目名を入れてください。
4) 元データの入ったシート名は「元データ」としてください。

EXCEL 必要な条件だけを別シートに自動コピーさせる方法

＞シート１のデータを追加入力しても、「東京」などの自動的に作成されたシートには自動反映されないんですか？

#3、#8のmatsu_junです。

#1,#6,#9です。

この回答への補足

#1,#6です。

#3のmatsu_junです。

この回答への補足

＞すみません。

ほぼ自動で転記できるVBAコードを書いてます。

＃4の補足です。

この程度の条件であれば、関数を工夫すれば、ほとんどの場合、希望の操作を行うことができます。

この回答への補足

VBAを利用しない場合

この回答への補足

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

EXCEL　必要な条件だけを別シートに自動コピーさせる方法