Excel VBA データを抽出して各シートにコピー

質問

色々調べましたが、同じものがなく苦戦しています。

Ａ　　Ｂ　　Ｃ　　Ｄ　　色　　成績
１　　　　　　　　　　　赤　　優
　　　１　　１　　　　　黄　　可
　　　１　　　　　　　　白　　優
　　　　　　　　　１　　青　　可
１　　　　　　　　１　　緑　　可

上記データをシート“Ａ”、“Ｂ”、“Ｃ”、“Ｄ”に振り分けたいです。
１が立てばそのシートに“色”より右側が転記されるようにしたいです。
ちなみに、１が重複で立っているものは、それぞれに転記です。

■シート“Ａ”は…
色　　成績
赤　　優
緑　　可

■シート“Ｂ”は…
色　　成績
黄　　可
白　　優

■シート“Ｃ”は…
色　　成
黄　　可

■シート“Ｄ”は…
色　　成
青　　可
緑　　可

となるようにです。
２日程、これだけに苦しんでいます。

ご教授いただければ幸いです。

回答No.10

myRange · ベストアンサー

またまたまたまた登場、myRangeです。

Ｅ列以降に何列あってもそれを転記する場合は
１行目の見出し列が何列あるか取得してやればいいわけです。
で、以下になります。

'--------------------------------------
Sub Test()
　Dim C As Integer
　Dim R As Long
　Dim ClmCnt As Integer

　ClmCnt = Cells(1, Columns.Count).End(xlToLeft).Column - 4

　For C = 1 To 4
　　　With Sheets(Cells(1, C).Value)
　　　　　.Cells.ClearContents
　　　　　.Range("A1").Resize(, ClmCnt).Value = Range("E1").Resize(, ClmCnt).Value
　　　　End With

　　　For R = 2 To Cells(Rows.Count, C).End(xlUp).Row
　　　　　If Cells(R, C).Value = 1 Then
　　　　　　　With Sheets(Cells(1, C).Value).Cells(Rows.Count, 1).End(xlUp)
　　　　　　　　　.Offset(1).Resize(, ClmCnt).Value = Cells(R, "E").Resize(, ClmCnt).Value
　　　　　　　End With
　　　　　End If
　　　Next R
　Next C

End Sub
'---------------------------------

●見れば分かると思いますが、変数ClmCntがＥ列以降の列数です。
　例えば、Ｈ列まであったら、Ｅ～Ｈ列で、４となります。
以上です。

お礼

試行錯誤しながら、何とか出来ました。
ありがとうございました！！！

回答No.9

myRange

またまた登場、myRangeです。

＞インデックスが有効範囲に無いとエラーになります。
＞以下が黄色になり…
＞With Sheets(Cells(1, C).Value)

それは、指定したシート名がない、ということです。
先に回答した時の条件は満足されてますか？

セルＡ１，Ｂ１，Ｃ１，Ｄ１に入力されている値をシート名として利用してますので
そこに入力されている値と実際のシート名が一致してないからエラーがでるのです。

一致しているようにみえても、
ＡＢＣなどのローマ字や１２３などの数字であれば全角、半角では違うことになります。

そこらをちゃんと確認してから再度実行のこと。

確認してもおかしいところはない、ということでしたら、
Ａ１～Ｃ１に入っている値とシート名を提示してください。
もちろん、実行したコードも一緒に。

●なお、提示のコードはちゃんと動作するコードです
以上です。

お礼

ありがとうございます！

出来ました！！

ご指摘のシート名が違っていました。

もう１点だけ良いですか。

Ｆ列以降（Ｇ列～）に情報を追加し、同様に転記するには
どこをいじれば良いのでしょうか。

“成績”の右に情報を追加していきたいのです。。

回答No.8

myRange

回答４、myRangeです。

追加されないようにする場合は、マクロの最初でクリアーしてやればいいのです。

'--------------------------
Sub Test()
　Dim C As Integer
　Dim R As Long

　For C = 1 To 4
　　　With Sheets(Cells(1, C).Value)
　　　　　.Cells.ClearContents　　　　　'●クリアー
　　　　　.Range("A1:B1").Value = Range("E1:F1").Value
　　　End With

　　　For R = 2 To Cells(Rows.Count, C).End(xlUp).Row
　　　　　If Cells(R, C).Value = 1 Then
　　　　　　　With Sheets(Cells(1, C).Value).Cells(Rows.Count, 1).End(xlUp)
　　　　　　　　　.Offset(1).Resize(, 2).Value = Cells(R, "E").Resize(, 2).Value
　　　　　　　End With
　　　　　End If
　　　Next R
　Next C
End Sub
'---------------------------

以上です。

お礼

ありがとうございます。

インデックスが有効範囲に無いとエラーになります。

以下が黄色になり…
With Sheets(Cells(1, C).Value)

回答No.7

noname#130090

#3です。
これでいいんじゃないでしょうか？

Sub test01()
　　Dim i As Long, j As Long
　　Const ShName As String = "ABCD"
　　For j = 1 To Len(ShName)
　　　　With Sheets(Mid(ShName, j, 1))
　　　　　　.Range("A1").CurrentRegion.ClearContents
　　　　　　.Range("A1") = "色"
　　　　　　.Range("B1") = "成績"
　　　　End With
　　Next j
　　For i = 2 To Range("E2").End(xlDown).Row
　　　　If Range("E" & i) <> "" Then
　　　　　　For j = 1 To Len(ShName)
　　　　　　　　If Range(Mid(ShName, j, 1) & i) <> "" Then
　　　　　　　　　　With Sheets(Mid(ShName, j, 1)).Range("A65536").End(xlUp)
　　　　　　　　　　　　.Offset(1) = Range("E" & i)
　　　　　　　　　　　　.Offset(1, 1) = Range("F" & i)
　　　　　　　　　　End With
　　　　　　　　End If
　　　　　　Next j
　　　　End If
　　Next i
End Sub

回答No.6

liberty01

※貼り付ける前に私の書いたコードを下記の間に入れて、それを貼り付けてね！！

sub Test()
　●私が書いたコード
end Sub

■コードを貼り付ける手順
1:Excelを開く
2:「ツール」　－＞　「マクロ」　－＞　「Visual　Basic　Editor（V）　Art+F11」を選択
3:VBE（Visual　Basic　Editor）画面が表示される
4:画面の左側に「プロジェクトーVBAProject」ってあるので、その枠内で右クリック
5:右クリックのメニューの中かから「挿入」　-＞　「標準モジュール（M)」　を選択
6:「Module1」というのが作成され、画面の右側の枠にコードを書けるようにフォーカスが当たります。
7:そこに私の書いたコードを張って、ファイルメニューから保存してください。

■マクロ実行手順
1:VBEの画面を閉じて、元のExcelの画面へ
2:「ツール」　－＞　「マクロ」　－＞　「マクロ」　を選択
3:先ほど作った「Module1」（たぶんTestかも・・・・ｗ）というのを選択して「実行」ボタンを押します。
※注意：マクロ実行前に分割するデータががあるシートを選択した状態で実行してね！！

これでマクロの作成と実行が可能になると思います。

お礼

ありがとうございます。

度々で申し訳ないです。
シートＢ～Ｄに転記されません。。。

回答No.5

noname#130090

#3です。

＞転記したいです。

では途中の「Const ShName As String = "ABCD"」
と書いてある行の下に

　　For j = 1 To Len(ShName)
　　　　With Sheets(Mid(ShName, j, 1))
　　　　　　.Range("A1") = "色"
　　　　　　.Range("B1") = "成績"
　　　　End With
　　Next j

を挿入してみてください。

お礼

ありがとうございます。
出来ました！

ただ、下記同様、マクロを実行する度に下に追加されていきます。

最新だけ転記したいのですが・・・

お手数おかけします。

回答No.4

myRange

見出し行が、１行目で、A1～D1にシート名Ａ、Ｂ、Ｃ、Ｄが入力されいて、
かつ、シートＡ、Ｂ、Ｃ、Ｄは既に存在するものとした場合。

下記を標準モジュールにコピペして、データのあるシートをアクティブにして実行。

'------------------------
Sub Test()
　Dim C As Integer
　Dim R As Long

　For C = 1 To 4
　　　Sheets(Cells(1, C).Value).Range("A1:B1").Value = Range("E1:F1").Value
　　　For R = 2 To Cells(Rows.Count, C).End(xlUp).Row
　　　　　If Cells(R, C).Value = 1 Then
　　　　　　　With Sheets(Cells(1, C).Value).Cells(Rows.Count, 1).End(xlUp)
　　　　　　　　　.Offset(1).Resize(, 2).Value = Cells(R, "E").Resize(, 2).Value
　　　　　　　End With
　　　　　End If
　　　Next R
　Next C
End Sub
'-----------------------

以上です。

お礼

ありがとうございます。
マクロを実行する度に追加されますが、
追加されないようにするには、どうすれば良いでしょうか。

回答No.3

noname#130090

もう回答がなされておりますので
お目汚しですが私も作ってみました。
全データの書かれたSheetで実行してください。

Sub Macro1()
　　Dim i As Long, j As Long
　　Const ShName As String = "ABCD"
　　For i = 2 To Range("E2").End(xlDown).Row
　　　　If Range("E" & i) <> "" Then
　　　　　　For j = 1 To Len(ShName)
　　　　　　　　If Range(Mid(ShName, j, 1) & i) <> "" Then
　　　　　　　　　　With Sheets(Mid(ShName, j, 1)).Range("A65536").End(xlUp)
　　　　　　　　　　　　.Offset(1) = Range("E" & i)
　　　　　　　　　　　　.Offset(1, 1) = Range("F" & i)
　　　　　　　　　　End With
　　　　　　　　End If
　　　　　　Next j
　　　　End If
　　Next i
End Sub

必要でない場合はスルーしてください。

お礼

ありがとうございます。
色々あるんですね。

ちなみに、
タイトル行
色　　成績

は転記したいです。

回答No.2

liberty01

＃１のものですが。

あれ？VBAってかいてたので、てっきりわかってるのかと、、
要はマクロを組んで、マクロを実行させて、質問内容を実現したいってことですよね？

なのでVBEの画面を開いて、標準モジュールを追加してそれに、このコードを張ればいいんですが。。

ちなみにExcelのバージョンはなんでしょうか？
（説明するにもバージョンを・・・）

お礼

失礼しました。
バージョンは2003です。

VBAだということだけ調べた2日でわかったんです。

＞要はマクロを組んで、マクロを実行させて、質問内容を実現したいってことですよね？

⇒そうです。お手数おかけします。

回答No.1

liberty01

オートフィルタ使えば良いんじゃないの？
とりあえず試してみて、、出力先のシート名固定なんでちゃんとシート作んないと落ちます＞＜

'◆A=1のとき
'1:オートフィルタでデータ抽出
ActiveSheet.Range("$A$1:$F$5").AutoFilter Field:=1, Criteria1:="1"
'2:抽出部分のみコピー
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
'3:値をペーストする
Worksheets("シートA").Range("A1").PasteSpecial
'4:A～D列削除
Worksheets("シートA").Columns("A:D").Delete
'5:オートフィルタ解除
ActiveSheet.ShowAllData

'◆B=1のとき
ActiveSheet.Range("$A$1:$F$5").AutoFilter Field:=2, Criteria1:="1"
'2:抽出部分のみコピー
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
'3:値をペーストする
Worksheets("シートB").Range("A1").PasteSpecial
'4:A～D列削除
Worksheets("シートB").Columns("A:D").Delete
'5:オートフィルタ解除
ActiveSheet.ShowAllData

'◆C=1のとき
ActiveSheet.Range("$A$1:$F$5").AutoFilter Field:=3, Criteria1:="1"
'2:抽出部分のみコピー
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
'3:値をペーストする
Worksheets("シートC").Range("A1").PasteSpecial
'4:A～D列削除
Worksheets("シートC").Columns("A:D").Delete
'5:オートフィルタ解除
ActiveSheet.ShowAllData

'◆D=1のとき
ActiveSheet.Range("$A$1:$F$5").AutoFilter Field:=4, Criteria1:="1"
'2:抽出部分のみコピー
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
'3:値をペーストする
Worksheets("シートD").Range("A1").PasteSpecial
'4:A～D列削除
Worksheets("シートD").Columns("A:D").Delete
'5:オートフィルタ解除
ActiveSheet.ShowAllData

お礼

早速アドバイスありがとうございます。

'◆A=1のとき
'1:オートフィルタでデータ抽出

から

'5:オートフィルタ解除
ActiveSheet.ShowAllData

までコピペしてどこかに張り付ければ良いのでしょうか。
素人で申し訳ないです。