助けてください。 VBAで内容を抽出させてコピーする方法

質問

助けてください。プログラムが苦戦しており全くわからずで困っています。まずエクセルのシート１に以下のような表があります。

（シート１）
　　 A 　　　　　　　B 　　　　　　　 C　　　　　 D
1 名前 　 　勤務体制
2 佐藤　　　夜勤務
3　鈴木　　　昼勤務
4　田中　　　昼勤務
5　小林　　　夜勤務
6　遠藤　　　変則勤務
7　松田　　　夜勤務

それでシート２では勤務体制を打つ欄がありまして(A1セル)、
その欄にたとえば『夜勤務』と打ったら以下のように
シート１のＢ列にあったものを判別してA列の内容をシート２へコピー
したいのです。（先頭　Ｂ２セル）（シート２のＢ～Ｄはマージセルなので値のみのコピーでいいのですが・・・）

（シート２）
A 　　　　　　B 　　　　 C　　 D
1 夜勤務
2　　　　　　佐藤
3　　　　　　小林
4　　　　　　松田

なんとかこれを作成させたいのですが、何日もこれで悩みプログラムができない状態なので、みなさんのお力をかしていただけないでしょうか？　お願いいたします。助けてください。

もしわかればでいいのですが、コピーの数が１０個を超えましたら、
超えた分はシート３にも同じ欄で同じ形の表がありますので、
そちらにコピーさせたいのですが、可能なのでしょうか？
もしわかればでいいですので・・・m(_ _)m
プログラムを教えて頂けたら本当に幸いです。
こんな私にお力を貸して頂けないでしょうか？

回答No.7

kopepe · ベストアンサー

kopepeです。

１３個ずつですと
１番
２番から１４番
１５番から２７番
２８番から４０番となるかと思いますので、それで記載します。

iCnt = 0
iGyo = 1
iCol = 2 ' ２列目に固定
Do While Sheet1.Cells(iRow, 2) <> ""
If Sheet1.Cells(iRow, 2) = sData Then
Select Case iCnt
Case 1 ' １番がおわった後ということで２番になったら
Sheet3.Activate ' シートを変える
iGyo = 1 ' 複写する行をリセットします
Case 14 ' １４番のあと、つまり１５になったら（繰り返し）
Sheet4.Activate
iGyo = 1
Case 27
Sheet5.Activate
iGyo = 1
End Select
iGyo = iGyo + 1 ' ここでインクリメントすると、初期値が１なので２行目から始まる
Cells(iGyo, iCol) = Sheet1.Cells(iRow, 1)
iCnt = iCnt + 1
End If
iRow = iRow + 1
Loop

これなら、１５個ずつでも２９個ずつでも対応できると思います。
Case の数値を何番の後かという事に設定すればよいからです。
最初が０なのでわかりにくいかも知れませんが、当初は余りを使用していたためこのようになりました。
また、シート数が増えても少しの変更で可能です。

今回はテストしてないので、もしかしたら記載ミスがあるかも知れませんが、エラーの内容で判断すれば解決できると思います。

お礼

何回も大変ありがとうございました。なぞが解決しましたのでkopepeさんには数え切れないほどに感謝をしております。本当にありがとうございました。

補足

ご回等いただいてから返事が遅れてしまいすいませんでした。あれかたずっと徹夜でヒントをもとにプログラムを書いたりしてたのですが、どうしても解決できませんでした。kopepeさんのを上のプログラムで総合すると、以下のとおりになるのでしょうか？
Public Sub Sabori()
Dim sData As String ' 対象とする勤務態勢用
Dim iRow As Integer ' シート１で検索するためのカウンタ
Dim iCnt As Integer ' 対象が見つかったときのカウンタ
Dim iGyo As Integer ' コピーするための行数を格納するため

' -------------------------------
sData = Sheet2.Cells(1, 1) ' シート１のＡ１にある文字列（対象とする勤務態勢）
iRow = 2 ' 検索を始める行番号
iCnt = 0 ' ＶＢＡでは無意味だけど初期化
iGyo = 0 ' 　　同上
' -------------------------------

'Sheet2.Activate
iCnt = 0
iGyo = 1
iCol = 2 ' ２列目に固定
Do While Sheet1.Cells(iRow, 2) <> ""
If Sheet1.Cells(iRow, 2) = sData Then
Select Case iCnt
Case 1 ' １番がおわった後ということで２番になったら
Sheet3.Activate ' シートを変える
iGyo = 1 ' 複写する行をリセットします
Case 14 ' １４番のあと、つまり１５になったら（繰り返し）
Sheet4.Activate
iGyo = 1
Case 27
Sheet5.Activate
iGyo = 1
End Select
iGyo = iGyo + 1 ' ここでインクリメントすると、初期値が１なので２行目から始まる
Cells(iGyo, iCol) = Sheet1.Cells(iRow, 1)
iCnt = iCnt + 1
End If
iRow = iRow + 1
Loop
End Sub

これで実行するとなぜかシート２のＢ２に１個、シート３からは１３個づつとなるはずが、
シート２に１３個張り付き、シート３以降に複写されません。
それでやはり、kopepeさんのお力をお借りしたく思い、もう一度
お願いしたいです。本当に何度もすいません。
助けていただけないでしょうか？
参考書を買ってきて、勉強中なのですが、わたしの知識がおいついてないのかもしれません。すいません。

回答No.6

kopepe

kopepeです。

最初の１個だけはF4かも知れないしAA5かも知れないと言うことでしたので#5のような記述になったのですが、意味が図りかねています。

つまり、
１番はシート２のＢ２、
２番から１０番までがシート３のＢ２からＢ１０
１１番から２０番はシート４のＢ２からＢ１１
２１番から３０番はシート５のＢ２からＢ１１
という意味でしょうか。

もしそうなら

Do While Sheet1.Cells(iRow, 2) <> ""
If Sheet1.Cells(iRow, 2) = sData Then
If iCnt = 1 Then Sheet3.Activate '２番目からシートをかえる
If iCnt = 10 Then Sheet4.Activate ' １０になったら更にシートを変える
' 先ほどよりシートが繰り越されている
iGyo = iCnt Mod 10 + 2
'-------------------------- B2の場合。
'------------------------------F4なら4,6 AA5なら5,27
If iCnt = 0 Then
iGyo = 2
iCol = 2
End if
'------------------------------
Cells(iGyo, iCol) = Sheet1.Cells(iRow, 1)
iCnt = iCnt + 1
End If
iRow = iRow + 1
Loop

もし最初の１個をAA5にして、１から１０まではシート２のまま
１１からシート３に移るというのでしたら、
２番目からシートをかえるという行は削除し、
１０になったらSheet3として、
iGyo = 5
iCol = 27
とします。

私の理解が正しかったでしょうか。

補足

本当にすべてが参考になります。一気に知識が上がったような期がします。
こういうことです。
つまり、
１番はシート２のＢ２
それから以降はふつうに１３個筒（最後の変更ですm(__)m）ですので
２番から１４番までがシート３のＢ２からＢ１４
１５番から２８番はシート４のＢ２からＢ１４
２９番から４１番はシート５のＢ２からＢ１４
という意味です。　間違いなくシート５以上は存在しません。

回答No.5

kopepe

kopepeです

変動する条件がわかっていれば対処は出来ますが、
あらかじめ分かっていないとファジーな対処は私には出来ません。

このような方法はいかがでしょうか

Dim iCol As Integer
と宣言しておく事にします。
ここからが条件分岐
Select case (条件)
Case (ケース１)
iCol = (列番号)
iGyo = (行番号)
Case (ケース２)
iCol = (列番号)
iGyo = (行番号)
Case (ケース３)
iCol = (列番号)
iGyo = (行番号)
．．．．．．．
Case Else
iCol = (列番号)
iGyo = (行番号)
End select

Cells(iGyo, iCol) = Sheet1.Cells(iRow, 1)

とする方法です。

(条件)は、状況を表す文字なり数値を格納したセル等を指定します。
たとえばシート１のＤ１あたりに、「緊急招集」とか「お花見」とかの条件を入れます。
(ケース)は、それらの分岐内容です。
たとえば、「ほろ酔い」とか「弁当がまずい」とかです。

２つ３つの条件が複合して有る場合は、更にケースの中でIFやSelectCaseを入れ子にして作成します。

変動する条件がわかりませんので具体的ではないのですが、
SelectCaseのヘルプを参考にしてみて下さい。

補足

お早い回答うれしいです。では変動する条件としてこうしました？
シート２には
（シート２）
A 　　　　　　B 　　　　 C　　 D　　　　Ｅ
1 夜勤務　　　　　　　　　　　　　　　
2　　　　　　佐藤
3　　　　　　

という風に一個だけ入れることにしました。
それでシート３、シート４以降は固定の
（シート３）
A 　　　　　　B 　　　　 C　　 D　　　　Ｅ
1 　　　　　　
2　　　　　　小林
3　　　　　　松田
4　　　　
という風にＢ２～１０個分をいれるようにしました。
これではどうでしょうか？また十個を超えればシート４に行くという感じです。
最初の１個だけはシート２のＢ２にいれるということはできないでしょうか？

お願いいたします。m(_ _)m
何度も何度もすいません。本当にすいません。

回答No.4

kopepe

kopepeです。

複写開始行が１行目になったと理解して回答します。

iGyo = iCnt Mod 10 + 2 ' 対象の数を１０で割った余りを出し、行数を指定
の行は
iGyo = iCnt Mod 10 + 1
とします。これで１行目から開始します。
次に１行目の時だけＥ列、あとはＢ列にする方法です。

If iGyo = 1 Then
Cells(iGyo, 5) = Sheet1.Cells(iRow, 1)
Else
Cells(iGyo, 2) = Sheet1.Cells(iRow, 1)
End if

他には
Dim iCol As Integer
と宣言しておき
If iGyo = 1 Then iCol = 5 Else iCol = 2
Cells(iGyo, iCol) = Sheet1.Cells(iRow, 1)
とする方法もあります。

もしシート３以降は２行目から始まるのでしたら
If iGyo = 1 Then iCol = 5 Else iCol = 2
If iCnt >= 20 Then iGyo = iGyo + 1
Cells(iGyo, iCol) = Sheet1.Cells(iRow, 1)
と間に１行入れてください。
これなら２０以降、つまりシート３以降なら２行目から開始します。

補足

なんどもすいません。先ほどいったＥ１というのは場合によって変動するかもしれないので、複写開始行が１行目になったというわけではないのです。なのでＦ４かもしれませんしＡＡ５になるかもしれないのです。２個目以降は先ほどいった固定なのですが・・・。
なので１個に現れたのだけ特定位置にコピーできれば幸いなのですが・・
kopepeさんに何度も回答いただいてうれしく思っていますが、
もうkopepeさんしか解決お願いできる人がいないので
なんとかならないでしょうか？　助けてください。
期限がせまっていまして・・。

回答No.3

kopepe

#2のkopepeです。

Sheet1と記載されているシート名は、タブの名前と同じでない可能性があります。
VisualBasicEditorで
Sheet1(Sheet1)
Sheet2(Sheet2)
Sheet3(Sheet3)
となっているか確認してください。
場合によっては
Sheet2(Sheet1)
Sheet1(Sheet2)
Sheet3(Sheet3)
となっていたりするケースもあります。
タブの名前を変更すると、たとえば
Sheet1(たぶ１)
Sheet2(みみたぶ２)
Sheet3(たぶん３)
のように括弧内がタブ名になりますが、シート名は変わりません。
ですからアクティブにするシートを括弧の前のシート名にするか、
あるいは
Sheets("みみたぶ２").Activate
のようにタブ名を指定するかして、そのワークブックのシート構成にあうように変更してみてください。

補足

kopepeさん謎が解決しました。いわれた通りシート名が違っていました。
なんといったらよいかkapopoさんのおかげで、悩みが一気にとれていき
感動しています。なんとお礼をいったらよいか。。

それとkopepeさん本当に申し訳ないのですが、たとえば
夜勤務
と指定していくつかでてきますが、でてきたらシート２では
（シート２）
A 　　　　　　B 　　　　 C　　 D　　　　Ｅ
1 夜勤務　　　　　　　　　　　　　　　　佐藤
2　　　　　　小林
3　　　　　　松田
4　　　　　
という風にでてきた１個目だけ　Ｅ１　に。
以下にでてきたものはさっきいった通りのＢ２～１０個だけ、
１０個以上はシート３へ。
これはできないでしょうか？
急きょやるないようが１個だけかわってしまったので。
１行目にでてきたのだけ　Ｅ１にいれなければいけない状態になってしまいまして・・・・

回答No.2

kopepe

こんにちは。
いつもいろいろな人に助けてもらってますので、今回は恩返しに投稿します。

こんなので試してみてください。

Public Sub Sabori()
Dim sData As String ' 対象とする勤務態勢用
Dim iRow As Integer ' シート１で検索するためのカウンタ
Dim iCnt As Integer ' 対象が見つかったときのカウンタ
Dim iGyo As Integer ' コピーするための行数を格納するため

' -------------------------------
sData = Sheet2.Cells(1, 1) ' シート１のＡ１にある文字列（対象とする勤務態勢）
iRow = 2 ' 検索を始める行番号
iCnt = 0 ' ＶＢＡでは無意味だけど初期化
iGyo = 0 ' 　　同上
' -------------------------------
Sheet2.Activate ' 複写する先をアクティブにする(この方法でシートを変えてゆくため)
' 別のもっとスマートな方法もありますが．．．
' -------------------------------
Do While Sheet1.Cells(iRow, 2) <> "" ' シート１に社員がいるだけ検索する
If Sheet1.Cells(iRow, 2) = sData Then ' 勤務態勢が同じ人が見つかった場合 ===== ここから
If iCnt = 10 Then Sheet3.Activate ' １０になったらシートを変える
'If iCnt = 20 Then Sheet4.Activate ' ２０になったら更に次のシートに行く
' シートがあるだけ繰り返して入れておく
' ０から始まっているので、１０は１１人目になる
iGyo = iCnt Mod 10 + 2 ' 対象の数を１０で割った余りを出し、行数を指定
Cells(iGyo, 2) = Sheet1.Cells(iRow, 1) ' カレントシートのセルにデータを入れる
iCnt = iCnt + 1 ' みつかった数をインクリメントする
End If ' ====================================== ここまで
iRow = iRow + 1 ' 検索する行をインクリメントし、次の行に移る
Loop
End Sub

補足

kopepeさん本当にご回答うれしい限りで泣きそうです。何日も頭を悩ませてたことが解決しそうなので！
一つだけ質問させていただいてもよろしいでしょうか？
実行するとシート２のマージセルにコピーされないでシート１にコピーされてしまうのですが、どこを変更すればシート２にコピーされるのでしょうか・・？

回答No.1

porilin

可能かと言えば可能ですというか簡単です。
ちゃんとコーディングしても良いのですが、誰かが先に答えたら労力無駄なのでコ－ディングのヒントだけ。
ＶＢＡですよね？

シート２のＡ１に入力でキックする様にしてＡ１の内容を変数に入れ
　参照値=cells(1,1).value
シート１のＢ１から順番に見てゆきます。
sheets("シート１").select
縦位置 = 1
while cells(2,i)value > ""
if 参照値 = cells(2,i)value then
****ここにシート２に転機するコーディング*******
end if
i = i + 1
wend

if文の中にカウンタをつけて、１０個書いたら次のシートに書く等を記述すれば 「シート３にも」も対応できます。

解答欄にベタ入力なので、細かい部分間違いがあるかもしれませんが流れはイメージしていただけますか？
ちなみにシート２のＡ１はセレクトＢＯＸにした方が入力楽です。

補足

本当にご回答うれしく思います！！m(_ _)m porilinさんご足労ありがとうございます。
私もこのイメージは自分の中でも考えついたのですが（カウンタをつける等勉強になりました）、実際のコーディングがやはりわからないところが多々あるため、できたらプログラムをお教え頂けると幸いなのですが；；　もしporilinさんにお時間があればでいいのでお願いいたします。無理なお願いを少しでも聞いていただきまして本当にうれしい限りです。