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

質問

手間がかかるタイピングを簡単にさせるため、次のようか事ができないかと考えております。EXCELは中級クラスです。VBAなどを使う場合は、お手数ではございますが、超わかりやすくご回答頂ければ幸いです。

”シート１”に下記のような入力をすると、
”シート東京”には、東京の行だけがコピーされ、
”シート大阪”には、大阪の行だけがコピーされる。

販売　場所　　

１月　東京　　　
１月　大阪　　
１月　沖縄　　
２月　東京　　
２月　大阪　　
２月　沖縄

回答No.12

KenKen_SP · ベストアンサー

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

方法は2つあります。

・一度「東京」などのデータ入力シート以外を削除し、再度マクロで再構築
・コードをカスタマイズして、データ範囲の取得方法を変更する

前者を「前提」としてコーディングしましたので、前者で対応して下さい。

また、#9でも書きましたが「データをあるキーによりシートに仕訳したい」という要望をよく見かけます。したがって、mintanさん以外の方が今回と同様な事例にあった場合でも対応できよう汎用性を考慮しました。お役に立てればうれしいです。

＞...マクロってなんですか？(^_^;)

このように定型的な作業を自動化するため、あるいはEXCELの機能をユーザー好みに強化するためのツールです。

回答No.11

matsu_jun

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

回答No.10

KenKen_SP

#1,#6,#9です。

補足ですが、シート「東京」などを予め用意しておく必要はありません。データが入力されたシート1つのみ状態で、マクロを実行して下さい。

＜手順＞
1.　[Alt]+[F11]キーでVisual Basic Editor起動
2.　[挿入]-[標準モジュール]クリック
3.　開いたウインドウに#9の【以下コード（標準モジュール）】の次行から終わりまでをコピー＆貼り付け
4.　Visual Basic Editorを閉じる

その後、データのあるシートを選択し、

EXCELの[ツール]-[マクロ]-[マクロ]で SplitSh を実行します。

お礼

おお～～～～～！!(^^)!　no１０をみたらできたようです。大阪　沖縄シートも自動的にはいりましたよ！
(ToT)/　諦めかけていたんですが、できましたよ！最高に嬉しいです！本当にありがとうございます<m(__)m>ところで、マクロってなんですか？(^_^;)

補足

追加で恐縮ですが、シート１のデータを追加入力しても、「東京」などの自動的に作成されたシートには自動反映されないんですか？反映させるためには、どうしたらいいですか？ほんとうにすみませんです

回答No.9

KenKen_SP

#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

回答No.8

matsu_jun

#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列には「場所」が入っているものとして考えていまして、販売月だけが入力されていて場所が入力されていない行や、場所だけが入力されていて販売月だけが入力されている行があるとよろしくない。特に前者(販売月だけが入力されていて場所が入力されていない行がある)の状況だと、マクロの処理が途中で終了してしまいます。
その程度のことですので、ご心配ないよう。

補足

置き換えたあと、以下の様になりましたが、OKですか？
------------------------------------
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
------------------------------------
おかげさまで、やっとここまできました。
で、このあと、どうしたらいいのでしょうか？
東京シートに自動的にデータが入力されているとおもったら大間違いですか？　東京シートには何もありませんでした。もうひとがんばりおねがいします<m(__)m>

そもそも、マクロ自体がまったくわかりません。
マクロの画面を開くので精一杯です。お手数ですが、バカ丁寧にご教示頂ければ幸いでございます。ここの書き込みでファイル添付とかできるといいのにね～

回答No.7

macchan1

＞すみません。わかりません。　エラー表示になります。

数式を入力後、配列数式とするためにCtrl+Shift+Enterで確定しているでしょうか?

＞シート１で入力している内容と、東京シートの関数入力先をもう一度お教えいただけますでしょうか？

Sheet1のA1に販売、A2以下に月、B1に場所B2以下に場所データが入っていることと、入力するセルは東京シートのA2セル（A1セルが項目名として）に入力します。

回答No.6

KenKen_SP

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

回答No.5

macchan1

＃4の補足です。

エラー処理はINDEXの行がリストの選択範囲を超えたときに起こりますので、IF関数で例えば以下のような数式を追加すれば表示されなくなります。

IF(ROW(A1)+SUMPRODUCT(((Sheet1!$B$1:$B$100<>"東京")*1))>100,"",元の式）

データ数が100を超える場合は数式のすべての100の数字を1000や10000などに適宜変更してください。

回答No.4

macchan1

この程度の条件であれば、関数を工夫すれば、ほとんどの場合、希望の操作を行うことができます。
この場合は、配列数式で希望のデータを表示することができます。

販売月が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))

なお、上記の関数はエラー処理していません。

補足

すみません。わかりません。　エラー表示になります。
シート１で入力している内容と、東京シートの関数入力先をもう一度お教えいただけますでしょうか？

回答No.3

matsu_jun

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) 元データの入ったシート名は「元データ」としてください。

補足

とてもわかりやすいのですが、すみません。補足をお願いします。　5) Sub シート整理()～以降がまったくわかりません。ソースがみつからないのです。AとB列を全部入力していないからですか？AB列を簡単に入力するほうほうはありますか？

回答No.2

DoragonFang

とりあえず、ＶＢＡで作ってみました。
もっとスマートなのは他の方に任せます(^^ゞ
シートが１０枚まで対応します。それ以上の場合は、
「10」のところを任意に数字に変えてください。
なお、前提条件として、
(A) データは「Sheet1」、そのほかは「東京」「大阪」・・・というシート名
(B)シート名の「東京」「大阪」・・とデータのB列にある「東京」「大阪」は同じ（空白など入れないで、合致すること）。
(C)シート「東京」などには１行目からデータを並べる。

Sub 分類()
Dim Sh(10) As String
Dim I As Integer
Dim R As Integer

I = 1
For Each WS In Worksheets・・・・(1)
Sh(I) = WS.Name
Sheets(Sh(I)).Activate
Range("A1").Activate・・・・・(2)
I = I + 1
If I > 10 Then Exit For
Next

Sheets("Sheet1").Activate・・・・(4)
R = 2
Cells(R, 2).Activate
Do Until Cells(R, 2).Value = ""・・(5)
For I = 1 To 10
If Sh(I) = Cells(R, 2).Value Then・・(6)
Rows(R).Select
Selection.Copy
Sheets(Sh(I)).Activate
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Activate・・(7)
Sheets("Sheet1").Activate
End If
Next
R = R + 1
Cells(R, 2).Activate
Loop
Range("A1").Activate
End Sub

一応解説しておくと、
(1)の部分は各シートの名前をShという変数に代入しています。これはあとで検索しやすくするためです。
さらにActivateメソッドで各シートに移り、A1セルにカーソルを移動してます(2)。(3)は変数Shが１０までしか対応できないので、１０以上は無視するために記述しています。
(4)からが本編で、Sheet1に移り、B2セルにカーソルを移動しています。
(5)はカーソルのあるセルの内容が空白になるまで繰り返すという意味です。
(6)で、Sh（すなわちシート名）とセルのデータが一致するかどうか判定して、一致したら、その行を選択して、COPYします。そして一致したShのシートに移り、ペーストします。次に備えカーソルを１つ下げておきます(7)。
ループを抜けたら、Rをひとつカウントアップして、次の行にうつります。

それほど難しくはないと思いますが、いかがでしょう？