１シート内にまとめられているデータを分割してコピーし、それを別の複数の

質問

１シート内にまとめられているデータを分割してコピーし、それを別の複数のシートにペーストする方法があれば、教えて下さい。

例えば、学校の成績を、教科ごとに表示するシートから、生徒ごとに表示するシートへとデータをコピーする、なんていう場合を想定して下さい。

＜教科のシート＞
シート１：国語のテストの点数表（生徒１～３の点数の一覧）
シート２：数学のテストの点数表（生徒１～３の点数の一覧）
シート３：英語のテストの点数表（生徒１～３の点数の一覧）

＜生徒のシート＞
シート１０１：生徒１の英数国の点数
シート１０２：生徒２の英数国の点数
シート１０３：生徒３の英数国の点数

という場合、

シート１から、生徒１の国語の点数をコピーし、シート１０１へペースト。
シート１から、生徒２の国語の点数をコピーし、シート１０２へペースト。
シート１から、生徒３の国語の点数をコピーし、シート１０３へペースト。

シート２から、生徒１の数学のテンスをコピーし、シート１０１へペースト。
シート２から、生徒２の数学の点数をコピーし、シート１０２へペースト。
シート２から、生徒３の数学の点数をコピーし、シート１０３へペースト。

シート３から、生徒１の英語の点数をコピーし、シート１０１へペースト。
シート３から、生徒２の英語の点数をコピーし、シート１０２へペースト。
シート３から、生徒３の英語の点数をコピーし、シート１０３へペースト。

という具合に、コピー・ペーストを『自動化』して、行いたいのですが、
このようなことは可能でしょうか？
（実際のデータは、教科数も生徒数も、もっと沢山あります。）

方法としては、マクロ（ＶＢＡ）を利用したものでも結構です。
どなたかお詳しい方、お力をお貸し下さい。
必ずお返事致します。（ポイント付与も確実に行います。）

回答No.7

goo793ww · ベストアンサー

goo793wwです。
回答No.３～６を更に実用レベルまで改善した最新版を紹介します。
宜しければ次のURLから取得して下さい。
http://www7.plala.or.jp/ppnabe/Tools/Distribution_V10.0520.xls
以上

参考URL：

http://www7.plala.or.jp/ppnabe/

お礼

ダウンロードまでできるようにして頂き、終始、至れり尽くせりな回答でした！

回答No.6

goo793ww

'▼(10)値を各シートへ転記
myCnt = 0
ReDim x(1 To 1, 3 To lastCol)
For r = 1 To UBound(myVal)
If myVal(r, myL) = myKey(i) Then
myCnt = myCnt + 1
For c = 3 To lastCol
x(1, c) = myVal(r, c)
Worksheets(myKey(i)).Cells(c, kyoukaNo).Value = myVal(r, c) '…科目別:データ縦(行方向)展開
Next c
End If
Next r
Erase x
Next i
Set myDic = Nothing

'▼(11)エンド処理
Worksheets(BaSheet).Activate '…シート切替え
ActiveWindow.ScrollColumn = 1 '…左端列へスクロール
ActiveWindow.ScrollRow = 1 '…先頭行へスクロール
Range("C1").Select
Application.ScreenUpdating = True '…画面更新再開
rtn = MsgBox("●●●処理完了●●●", 64, "AP:教科シートを振分ける")
End Sub
'---------------------------------------------------------------------
'▲ソースコードは以上です。
'最後に「教科シート」と「生徒別シート」を画像添付しておきます。
'以上

お礼

画像まで付けて頂き、大変分かりやすかったです。

回答No.5

goo793ww

'▼(6)シート有無チェック(なければ最後部に追加)
For i = 0 To myDic.Count - 1
For Each mySh In Worksheets
myFlg = False
'▼(7)振分先シートが有ればデータ領域を削除する
If mySh.Name = myKey(i) Then
myFlg = True
Worksheets(myKey(i)).Activate '…シート切替え(部分削除:シートをActiveにする必要がある)
xxRow = Worksheets(myKey(i)).Cells(Rows.Count, kyoukaNo).End(xlUp).Row
Worksheets(myKey(i)).Range(Cells(3, kyoukaNo), Cells(xxRow, kyoukaNo)).ClearContents
Exit For
End If
Next mySh
'▼(8)振分先シートが無ければシートを追加する
If myFlg = False Then
ActiveWorkbook.Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = myKey(i)

'追加シートの書式設定をする
Cells.Select
With Selection.Font
.Name = "ＭＳ ゴシック"
.Size = 11
End With
Range("A1").Select
End If

'▼(9)項目を各シートへ表記
Worksheets(myKey(i)).Activate '…シート切替え
Worksheets(myKey(i)).Rows("2:2").NumberFormatLocal = "@" '…書式(文字列)
Worksheets(myKey(i)).Columns("A:A").NumberFormatLocal = "@" '…書式(文字列)
Worksheets(myKey(i)).Range("A1").Value = "ID:" & myKey(i) '…生徒ID
Worksheets(myKey(i)).Range("B1").Value = myVal(i + 1, 2) '…生徒名
Worksheets(BaSheet).Range("C2:G2").Copy
Worksheets(myKey(i)).Range("A3").PasteSpecial Paste:=xlPasteValues, Transpose:=True '…試験日(行列を入替えて値張付け)
Application.CutCopyMode = False '…Copy:クリップボード解放
Worksheets(myKey(i)).Cells(2, 1).Resize(1, kyoukaSu).Value = kyouka '…教科名表示
Worksheets(myKey(i)).Range(Cells(2, 2), Cells(2, kyoukaSu)).HorizontalAlignment = xlRight '…右端表示
Worksheets(myKey(i)).Range(Cells(2, 1), Cells(2, kyoukaSu)).Interior.ColorIndex = 24 '…背景色:淡い紫
Range("A1").Select

'▼(10)値を各シートへ転記

お礼

ありがとうございました　＾＾

回答No.4

goo793ww

'▼(2)アクティブSheet名が教科名と同じかを評価する
For i = 1 To kyoukaSu
If kyouka(i) = BaSheet Then
kyoukaNo = i
rtn = MsgBox("【" & kyouka(i) & "】教科シートを、生徒別シートに振分ます。" & vbCrLf & _
" 宜しいでしょうか", 36, _
"AP:教科シートを振分ける")
If rtn <> 6 Then
Exit Sub
End If
Exit For
End If
Next
If i > kyoukaSu Then
rtn = MsgBox("シート名が教科名と不一致!!…処理を中断します。" & Chr(13) & Chr(10) & _
"マクロは「教科名」シートをActiveにして実行して下さい。" & Chr(13) & Chr(10) & _
"特記:仕様は「シート名=教科名」です" & Chr(13) & Chr(10) & _
"VBA「教科名」配列を実状に合わせ修正して下さい。", 16, _
"AP:教科シートを振分ける")
Exit Sub
End If

Worksheets(BaSheet).Activate '…シート切替え

'▼(3)元データを配列に格納
lastRow = Worksheets(BaSheet).Range("A" & Rows.Count).End(xlUp).Row '…行下端get
lastCol = Worksheets(BaSheet).Cells(2, Columns.Count).End(xlToLeft).Column '…列右端get
Worksheets(BaSheet).Rows("2:2").NumberFormatLocal = "@" '…書式(文字列)
Worksheets(BaSheet).Columns("A:A").NumberFormatLocal = "@" '…書式(文字列)
Worksheets(BaSheet).Range(Cells(2, 1), Cells(2, lastCol)).Interior.ColorIndex = 43 '…背景(鶯色)
For i = 3 To lastRow
Worksheets(BaSheet).Range("A" & i).Value = Format(Worksheets(BaSheet).Range("A" & i), "000") '…生徒ID
Next i
myVal = Worksheets(BaSheet).Range(Cells(3, 1), Cells(lastRow, lastCol)).Value '…元データを配列に格納する

'▼(4)キーとする列を指定
myL = 1 '…生徒ID

'▼(5)myDicへデータを格納
Set myDic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(myVal)
If Not myVal(i, myL) = Empty Then
If Not myDic.Exists(myVal(i, myL)) Then
myDic.Add myVal(i, myL), 1
Else
myDic(myVal(i, myL)) = myDic(myVal(i, myL)) + 1
End If
End If
Next
myKey = myDic.Keys
'▼(6)シート有無チェック(なければ最後部に追加)

お礼

申し訳ございません、レスポンスが遅くなりました。
貴重なお時間を、本質問のために割いて頂き、本当にありがとうございます。
まだまだ私は初心者であるため、理解するのにお時間を頂きますが、
解読できましたら、必ずやお返事致しますので、もうしばらくお待ち下さい。
画像まで添付して頂き、懇切丁寧な回答に感謝感激です。

回答No.3

goo793ww

掲題の件、興味がわき実践向きに試作してみました。
お役に立てば幸いです。
<説明>
1.教科シートのレイアウト
1行目は仕組みとして割付ていません…自由に利用して下さい。
　A列 :生徒ID(数値入力可、但し文字列にマクロで強制します)
　B列 :生徒名
　C2～Z2 :試験日(例えば、1学期・2学期・3学期・05/01・06/01・・・)
C3右側下側 :データ入力欄(成績データ)
2.教科シートのネーミング
　自由(例えば、国語・数学・英語・・・が適当です)
　特記:この名前は、VBAマクロの「配列:kyoukaSu」に記載されている必要があります。
従い、VBA配列の「教科名」は実状に合わせ加筆修正して下さい。
尚、この配列順で生徒別シートへ成績が転記されます。
3.生徒シート
　無ければ生徒IDをシート名として自動生成します。
　即ち生徒別シートは事前に用意する必要は有りません。

※Excel2000,2003,2007,動作確認済みです。
▼下記をコピー張付けして試行してみて下さい。
　特記:回答内容は2000文字以内のようです…回答内容が分割されますが全て繋いで下さい。
'---------------------------------------------------------------------
Option Explicit
Option Base 1

Sub データ振分()
Dim myDic As Object
Dim myKey As Variant
Dim myVal As Variant
Dim x As Variant
Dim i As Long
Dim xxRow As Long
Dim r, c As Long
Dim mySh As Worksheet
Dim myFlg As Boolean
Dim lastRow As Long
Dim lastCol As Long
Dim myL As Integer
Dim myCnt As Long
Dim BaSheet As String
Dim kyouka As Variant
Dim kyoukaSu As Long
Dim kyoukaNo As Long
Dim rtn As Integer

'▼(1)教科名を配列に格納
kyouka = Array("試験日", "国語", "数学", "英語", "□□", "□□") '…★定数(教科を宣言する)
kyoukaSu = UBound(kyouka)

Application.ScreenUpdating = False '…画面更新停止
BaSheet = ActiveSheet.Name '…教科元シート名get

'▼(2)アクティブSheet名が教科名と同じかを評価する

お礼

その節はお世話になりました。
私のために、こんなにもよくして頂いて、誠に恐縮です。
次回、また質問することがありましたら、その際にも色々と教えてください。

回答No.2

n-jun

＜教科シート＞
Ｃ１には”学期”を数値で入れる。
セルの書式設定でユーザー定義：0"学期"　としている。
⇒画像では3と入れてる。

ＩＤを入れる行追加。
ＩＤ自体は数値で入れる。
セルの書式設定でユーザー定義：000
⇒画像では1 2 3　と入れている。

＜各生徒のシート＞
シート名はＩＤ：001 002 003 など。
Ａ列の教科名は事前に入れておく。
学期名はマクロ実行時に勝手に入る。

Sub try()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim r As Range
Dim i As Integer
Dim ID As String

Set ws1 = Worksheets("教科シート")

With ws1
i = .Range("C1").Value '学期

For Each r In .Range("C2", .Range("C2").End(xlToRight)) '生徒（Ｃ２～2行目の一番右のセルまで）

ID = Format(r.Offset(1).Value, "000") '生徒のID

Set ws2 = Worksheets(ID)

'各シートに学期の書込み
ws2.Range("A1").Offset(, i).Value = StrConv(i, vbWide) & "学期"

'各シートに点数の書込み
ws2.Range("A1").Offset(1, i).Resize(3, 1).Value = _
r.Offset(2).Resize(3, 1).Value

Next
End With

Set ws1 = Nothing
Set ws2 = Nothing
End Sub

一例まで。

お礼

回答、ありがとうございます。
教えて頂いたコードの解読と実践に、多少お時間を頂きますが、
必ず結果をレスポンス致しますので、しばらくお待ち下さい。
おそらく、教えて頂いたコードで問題なく、私のしたいことはできるものと思います。
もし、つまづくようなことがありましたら、適宜、補足など致しますので、
その際には、またアドバイスして頂けると大変有り難いです。
それでは、今しばらくお待ち下さい。
回答に画像まで添付して頂き、誠にありがとうございます。

回答No.1

n-jun

可能かと言われると可能な感じもしますけど。

教科のシートのどこで生徒を判断（生徒の名前がシート名？）し、
どこに点数があり、
それを生徒のシートのどこに書き込むのか、
シート構成等が不明です。

例えば、
http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_furiwake.html
『データをシートに振り分ける』の場合、

振り分け前のデータ（種類）が振り分けるシート名になります。
また振り分けるデータの位置と、書き込むセルの位置もわかります。

このようなシートの情報を提示されないと、
具体的な回答も難しいと思います。

お礼

ご指摘、ごもっともだなと思いました。
表の行列の構成などの説明が不足していましたね。

ということで、補足させて頂きます。

＜教科シート（１学期）＞　の構成は、

　　　　生徒１　生徒２　生徒３
国語　　８０　　９０　　８５
数学　　６８　　５６　　９０
英語　　７８　　６０　　８７

このような感じで。
一方、＜生徒シート＞は、

＊生徒１　のシート

　　　　１学期　　２学期　　３学期
国語　　８０　　　８７　　　８５
数学　　６８　　　９２　　　９０
英語　　７８　　　８０　　　７８

は、このような感じで。

＜教科シート＞にデータを手打ち入力した後、
マクロかなにかで、処理をすると、
＜生徒シート＞に必要な形式で必要なデータが、
＜教科シート＞から、コピー＆ペーストされるような、
そんな仕組みを考えています。

（例）
３学期の試験結果を、＜教科シート＞に手打ちした後、
そのデータ（国語、数学、英語の点数の列）がいっせいに、
各生徒のシートに、右端（２学期の点数の列の右隣）に追加されるような、
そんな仕組みです。

つまり、
＜教科シート＞　には、手打ちでデータを入力し、
＜生徒シート＞　には、自動でデータが入力される、
という仕組みなので、
人が手を加えるシートは＜教科シート＞のみ、となります。
（＜生徒シート＞は、閲覧のみ。）

他に何か不備がありましたら、またご指摘下さい。

補足

さらに、補足です。

＞教科のシートのどこで生徒を判断（生徒の名前がシート名？）

生徒の生徒識別番号（No.001～068)みたいなもので、生徒を判別するつもりです。
シート名については、目的のプログラムを組む際に必要と思われる名前で結構です。

どういう仕組みでプログラムが組まれることになるのか、私には現段階では分からないため、
シート名をどうしたら良いかも同時に分からない、ということです。
ご理解頂けると、嬉しいです。