エクセルで処理を繰り返す。Excel VBAで質問です。

質問

次のようなマクロを考えています。
“シート1”で県名をリストから選ぶと“シート2”のデータ(文字)
を“シート3”に入れていく、というものです。

“シート1”
C11セルがリストになっていて県名が選べる

“シート2”
A列に県名
1 東京都　ああああああ
2 dddd
3
4 てててててて
5 ggggggggggg
6 神奈川 つつつつつつ
7 qqqqqqqqqqqq
8 かかかかかかか
9 aaaaaaa

B列にデータが文字列であります。A列では空白になっていますが、
B列では1から5行目までデータがあります(東京都の場合)。ただ
3行目のように空白になってい場合もあります。

ここでやりたいのは、例えばシート1のリストが東京都の場合、
・シート2のA列に東京都を見つけて、
・シート2のA列が次の県名になるまでB列のデータを
・シート3のB17から下にコピーする

というものです。分からず困っていますがどなたか教えていただけないでしょうか。

※画面の設定がうまくいかないんですが、A列が県名、それ以外はB列に入っています。

回答No.2

mshr1962 · ベストアンサー

#1です。下記のコードをVBAのSheet1に貼り付けてください。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim RG1, RG2, RG3 As Range
Dim GYO As Long
Dim FL1 As Boolean
If Target.Address = "$C$11" Then
If Target = "" Then Exit Sub
Set RG1 = Target
Set RG3 = Worksheets("Sheet3").Range("B65530").End(xlUp)
If RG3.Row < 17 Then GYO = 16 - RG3.Row
For Each RG2 In Worksheets("Sheet2").Range("A1:A1000")
If RG2 = RG1 Then FL1 = True
If FL1 = True Then
If RG2 <> RG1 And RG2 <> "" Then Exit For
GYO = GYO + 1
RG3.Offset(GYO, 0) = RG2.Offset(0, 1)
End If
Next RG2
End If
End Sub

お礼

非常にすごいもので感謝です。無駄にしたくないので、ひとつだけよろしいでしょうか。
Sheet2のA列の都道府県名で、一番下に位置する都道府県が選択された場合、処理がとまらず、ずっと探し続けているようです。
自分では処置方法が分からず、ここまで教えていただけて恐縮ですがmshr1962さんに伺う以外ないと思い、またお尋ねしたいと思っています。

回答No.4

Wendy02

こんばんは。

#2さんのマクロを読みながら、
>一番下に位置する都道府県が選択された場合、処理がとまらず、ずっと探し続けているようです。

というよりも、ある程度、マクロを予想した表が出来上がっていれば、そのようなことがなかったと思います。

本来は、空白はあってもなくても、都道府県ひとつに対して、固定の行数を決めるべきだったと思います。例えば、5行とか、そういう表示フォームができていればよかったのですね。

#2さんの処理を途中で終わらせるために、簡単な方法としては、
B列の最終行の次の行のA列に、何か、終了のための関係のない文字をひとつ入れてあげればよいです。

例：
沖縄　　　ccc
　　　　　ddd
　　　　　eee
　　　　　fff
*　　　　　←例えば、最後の行に、このようにすれば終わります。
-----------------------------

私も作ってみました。ダイレクトで、Sheet2のA列を探します。
私の場合は、そのままでも可能です。

----------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim i As Variant
　　Dim j As Long, k As Long
　　Dim Sh2 As Worksheet
　　Dim Sh3 As Worksheet

　　Set Sh2 = Worksheets("Sheet2")
　　Set Sh3 = Worksheets("Sheet3")

　　If Target.Count > 1 Then Exit Sub
　　If Target.Address(0, 0) <> "C11" Then Exit Sub
　　If Target.Value = "" Then Exit Sub
　　With Sh2
　　　　i = Application.Match(Target.Value, .Columns(1), 0)
　　　　If Not IsError(i) Then
　　　　　　j = .Cells(i, 1).End(xlDown).Row
　　　　　　k = Sh3.Range("B65536").End(xlUp).Row
　　　　　　If k < 17 Then k = 17 Else k = k + 1
　　　　　　If j < 65535 Then
　　　　　　　　.Range(.Cells(i, 2), .Cells(j - 1, 2)).Copy Sh3.Cells(k, 2)
　　　　　　Else
　　　　　　　　j = .Cells(65536, 2).End(xlUp).Row
　　　　　　　　.Range(.Cells(i, 2), .Cells(j, 2)).Copy Sh3.Cells(k, 2)
　　　　　　End If
　　　　Else
　　　　　MsgBox "『" & Target.Value & "』は、リストから見つかりません。", 48
　　　　End If
　　End With
　　Set Sh2 = Nothing
　　Set Sh3 = Nothing
End Sub

お礼

Wendy02さんおはようございます。
現象はそういうことなんですね。まったく意識していませんでした。
ところでWendy02さんのコードですが、試させていただきました。
すごいものでした。本当にありがとうございます。解決に導いていただいて心苦しいのですがmshr1962さんには辛抱強くお付き合いいただいた経緯があり、今回次点ということでお許しいただけますでしょうか。申し訳ありません。本当に助かります。

回答No.3

imogasi

既に近いところまで回答は出ているようですが、こういう課題を考えるとき、まず日本語文章でもって整理することをお勧めします。人間がコンピュターを使わずやったらどうなるかを書き出してみる。そして何をコード上で作れれば、通しで課題が実現するのか。そしてこの質問では、それは
（１）Sheet1のC11で県名が選択されたら県名の値をとる。こういう値　　は一旦変数に代入するものです。
　　ここでリストの「コンボボックスをクリックしたら反応」とした　　いが、入力規則では、それが出来ないので、セルの値のChangeイ　　ベントというもので捉まえる。この点は経験から。
（２）選択された県名でSheet2のA列の県名のあるセルを探索する
　　－－＞色々なやり方があって、迷うという点では難しいが、私は
　　エクセル関数のMATCH関数がVBAでも使えるので、それを使うのを　　やってみる。
（３）見つかった行の次の行から、下に空白で無い行までの各行につ　　　いて
　　　列データ（＝項目、下記例では「内容」）をSheet3に代入する。
　　　Sheet2から採ってくる行数は不定らしいが、数行だから、１行　　　１行聞いて行けばよいだろう。
（４）Sheet3はSheet２で検索した結果を（A）累積するのか（B)定位置セル（B17からの数行）に（指定県が変われば）上書きするのか。（A)か（B)か質問でははっきりしない。
　以上でサブの課題に分けられる。
こういう作業の説明も、各部分のコードを検討した様子も質問では伺えず、回答者に作ってくださいと丸投げになっている。
（定則）課題は分割して当たれ。
ーー
実例説明すると
Sheet1
入力規則で
東京都
神奈川県
千葉県
を設定
ーーー
Sheet2に
A1:B17に
県名　　内容
東京都 a
ーーー b
ーーー c
ーーー d
ーーー e
ーーー f
千葉県 s
ーーー g
ーーー f
ーーー g
ーーー h
神奈川県 c
ーーー s
ーーー d
ーーー f
ーーー g
（ーーーは空白セルのつもり。）のデータがあるとする。
ーー
Sheet1のシートモジュールに
Private Sub Worksheet_Change(ByVal Target As Range)
x = Worksheets("Sheet1").Range("C11")
MsgBox x
y = WorksheetFunction.Match(x, Worksheets("Sheet2").Range("A1:A100"), 0)
MsgBox y
'--
j = 17
Worksheets("Sheet3").Cells(j, "C") = Worksheets("Sheet2").Cells(y, "B")
y = y + 1
j = j + 1 '以上県名のある行の内容を移す
While Worksheets("Sheet2").Cells(y, "A") = ""
MsgBox Worksheets("Sheet2").Cells(y, "B")
Worksheets("Sheet3").Cells(j, "C") = Worksheets("Sheet2").Cells(y, "B")
y = y + 1
j = j + 1 '以上県の名の無い行の内容を移す
Wend
End Sub
を作る。
ーーー
操作と結果
Sheet1のC11の選択を、千葉県を選択すると、千葉県のメッセージが出て
Sheet2の千葉県のある行番号８がメッセージで出る。
そしてSheet3のB１７から下に
s
g
f
g
h
ーー
Msgboxは確認テスト用なので、用済み段階以後は削除
B列の内容に空白セルが有り得て、Sheet3にはその後の行で詰めるなら、IF文でB列セルが空白か聞いて、空白なら代入をスキップしてください。

お礼

ご回答ありがとうございます。今mshr1962さんのコードためさせていただいており、少し時間がかかるかもしれませんがお許しください。

回答No.1

mshr1962

一例です。
Sheet1のA1からセルがブランクになるまで都道府県名をチェック
Sheet2で同じ値を見つけて、B列のその行をSheet3にセット
Sheet2で次の値になるまで、B列のその行をSheet3にセットの繰り返し
Sheet1のセルがブランクになると終了

Sub BCCOPY()
Dim RG1, RG2 As Range
Dim GYO As Long
Dim FL1 As Boolean
GYO = 16
For Each RG1 In Worksheets("Sheet1").Range("A1:A48")
If RG1 = "" Then GoTo TONEXT
For Each RG2 In Worksheets("Sheet2").Range("A1:A1000")
If RG2 = RG1 Then FL1 = True
If FL1 = True Then
If RG2 <> RG1 And RG2 <> "" Then Exit For
GYO = GYO + 1
Worksheets("Sheet3").Range("B" & GYO) = RG2.Offset(0, 1)
End If
Next RG2
TONEXT: FL1 = False
Next RG1
End Sub

お礼

mshr1962さんこんばんは。
Sheet1のA1からセルがブランクになるまで都道府県名をチェック
というようにご提示いただいたのですが、私の質問文が言葉足らずでした。Sheet1はC11が入力規則のリストで作ってあり、そこで都道府県名がひとつ選べるようになっています。
あくまで参考サンプルで、というご提示であったら誤解をし、申し訳ありません。
できたら
Sheet1のC11の都道府県名をチェック
というような形でお教えいただけとありがたいです。