質問：特定文字列から空白行までの抽出

質問：特定文字列から空白行までの抽出
お世話になります、ネットで公開されているVBAを修正して何とかなっているVBA初級者です。
毎月excelで出力されたファイルを元に関数で整形したと思っていますが、”北棟２”の開始
するセル位置は解っているのでそれを基準に利用するのは簡単ですが、7777村上まで（空
白があるまで）を抜き出して"sheet_work"もしくは"北棟２"とういうsheetのB8セルに貼り
付けたいと考えています。
北棟２だけではなく、空白に挟まれた行は毎月変動するために関数でのセル指定が役に立ちま
せん。この場合、北棟２、南棟１、西棟２、東棟１、東棟３といた文字列の次の行のA,B,C列
から空白が発生する行までを整形しやすいsheetか文字列通りのsheet名のB8セルに貼り付ける
方法が御座いましたらご教授お願いいたします。関数だけで力業で可能でしたらそちらもお教
えお願いします。

以下が出力されますが、空白から空白までは一定では無く、増減します。
小計の行は不要です。
　　　　　Ａ　　　Ｂ　　Ｃ
5　　xxxxxx名　　　日付　
6　　
7　　　　　北棟２
8　　1111鈴木　5
9　　2222武田　5
10　　11200山田　5
11　　4444高橋　4
12　　5555佐藤　5
13　　6666小林　4
14　　7777村上　0
15　　　
16　　　　　小計　28
17　　
18　　　　　南棟１
19　　1001中村　4
20　　1002伊藤　5
21　　1003吉田　4
22　　20110佐々木　5
23　　1005木村　3
24　　1006渡辺　0
25　　1007田中　4
26　　
27　　　　　小計　25
28　　
29　　　　　西棟２
30　　10020森　2
31　　2010岡田　1
32　　2033池田　0
33　　2058井上　5
34　　
35　　　　　小計　8
36　　
37　　　　　東棟１
38　　7854石田　4

45　　　　　東棟３
46　　4471石岡　2

No.6 ベストアンサー 回答者： kmetu 回答日時： 2010/05/29 13:52

Sheet1のコードとしてください

Sub test()

Dim m_Start As Object
Dim m_Tou As Variant
Dim Check As Boolean
Dim EndAddress As String
Dim i As Integer, j As Integer

m_Tou = Array("北棟２", "南棟１", "西棟２", "東棟１", "東棟３")

For i = 0 To UBound(m_Tou)

Set m_Start = Range("B:B").Find(what:="*" & m_Tou(i) & "*")

Check = True
j = 1

Do
If Range("B" & m_Start.Row + j).Value = "" Then
Check = False
EndAddress = Range("B" & m_Start.Row + j - 1).Offset(0, 1).Address

End If
j = j + 1
Loop Until Check = False

Range(m_Start.Offset(1, -1).Address & ":" & EndAddress).Copy
Sheets(m_Tou(i) & "H").Range("B8").PasteSpecial

Next

Application.CutCopyMode = False

End Sub

この回答へのお礼

ありがとう御座いました。こんなに早く目的が達成できるとは思っておりませんでした。
完璧です。
Find(what:="*" & m_Tou(i) & "*")　の"*"や所々解らない部分もありますが、助かりました
ありがとう御座います。

お礼日時：2010/05/29 17:03

No.5 回答者： n-jun 回答日時： 2010/05/29 13:47

＃２です。

＞（手動で”北棟２”の範囲を”北棟２Ｈ”のシートのB8以下へ貼り付けしました）、
セルの"北棟２"がシート名"北棟２Ｈ"なら、

rr.Copy Worksheets(r.Item(1).Offset(, 1).Value & "Ｈ").Range("B8")

となります。
⇒アップされたファイルは観られないみたい？

この回答へのお礼

お手数かけました、ジオシティーズは制限が多かったようです。ご迷惑をおかけしました。
もう一度ファイルをアップしました。
https://www.webfile.jp/dl.php?i=730597&s=b7eac4e …
よろしくお願いいたします。

お礼日時：2010/05/29 17:18

No.4 回答者： kmetu 回答日時： 2010/05/29 11:33

ANo3 修正です

EndAddress = Range("A" & m_Start.Row + j - 1).Address

↓

EndAddress = Range("A" & m_Start.Row + j - 1).Offset(0, 1).Address

この回答への補足

ありがとう御座います。VBAが途中で止まってしまい、そもそも私の表現がよろしくない事に気がつきました。
ファイルをアップ致しました。

http://www.geocities.jp/hartpopoo/test.xls

この中でシート名に"H"を追加しておりますが、敢えて別名にすることが便利だと考えました。
（手動で”北棟２”の範囲を”北棟２Ｈ”のシートのB8以下へ貼り付けしました）、他のシートにも同様に該当する（当てはめる）シートのB8へそれぞれデータを貼り付けたいと思っております。
頼り過ぎて申し訳ありません。

補足日時：2010/05/29 13:22

No.3 回答者： kmetu 回答日時： 2010/05/29 11:28

Sub test()

Dim m_Start As Object
Dim m_Tou As Variant
Dim Check As Boolean
Dim EndAddress As String
Dim i As Integer, j As Integer

m_Tou = Array("北棟２", "南棟１", "西棟２", "東棟１", "東棟３")

For i = 0 To UBound(m_Tou)

Set m_Start = Range("A:A").Find(what:="*" & m_Tou(i) & "*")

Check = True
j = 1

Do
If Range("A" & m_Start.Row + j).Value = "" Then
Check = False
EndAddress = Range("A" & m_Start.Row + j - 1).Address
End If
j = j + 1
Loop Until Check = False

Range(m_Start.Address & ":" & EndAddress).Copy
Sheets(m_Tou(i)).Range("B8").PasteSpecial

Next

Application.CutCopyMode = False

End Sub

でいかがですか

No.2 回答者： n-jun 回答日時： 2010/05/29 11:19

n-junです。

Sub try2()
Dim r As Range
Dim rr As Range

With Worksheets("Sheet1") ' データのあるシート

For Each r In .Range("A6", .Cells(Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas

Set rr = r.Offset(1).Resize(r.Rows.Count - 1, 2)

rr.Copy Worksheets(r.Item(1).Offset(, 1).Value).Range("B8")

Next

End With

Set rr = Nothing
End Sub

こちらならどうでしょうか。

この回答への補足

何度もありがとう御座います。
rr.Copy Worksheets(r.Item(1).Offset(, 1).Value).Range("B8")
で止まってしまいます。シートレイアウトの伝え方がまずいのだと思います。
ファイルをアップ致しました。

http://www.geocities.jp/hartpopoo/test.xls

この中でシート名に"H"を追加しておりますが、敢えて別名にすることが便利だと考えました。
（手動で”北棟２”の範囲を”北棟２Ｈ”のシートのB8以下へ貼り付けしました）、他のシートにも同様に該当する（当てはめる）シートのB8へそれぞれデータを貼り付けたいと思っております。よろしくお願いします。

補足日時：2010/05/29 13:25

No.1 回答者： n-jun 回答日時： 2010/05/29 09:40

シート構成が今一不明でしたが。

・このシートはＡ～Ｂ列に値がある。
・このシートの６行目以下が対象である。
・このシートのＡ列にあるデータの塊のうち、
”小計”を除いた塊で１つ目はコピーするシート名を指定する。
・指定されたシートのＢ８以下に、このシートのＡ列の値をコピペする。
・各シートは事前に存在するものとする。

と判断しました。

Sub try()
Dim r As Range

With Worksheets("Sheet1") ' データのあるシート

For Each r In .Range("A6", .Cells(Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants, 3).Areas

If r.Item(1).Value <> "小計" Then r.Copy Worksheets(r.Item(1).Value).Range("B8")

Next

End With

End Sub

ご参考になれば。

この回答への補足

早速のご回答ありがとう御座います、投稿後に修正が必要な事にに気がつきましたが回答を頂けるまで修正が出来ずに困っておりました。申し訳ありません。
　　　　　Ａ　　　Ｂ　　Ｃ
5　　xxxxxx名　　　日付　

5行目までは不要な文字で御座います

6　 空白　　空白　　　空白　
7　　30010 　北棟２　　　　　←30010がＡ列　北棟２がＢ列（30010が記入漏れ）　
8　　1111　　鈴木　5　　　　抽出したいデータ部分（A:1111　B:鈴木　C:5）
9　　2222　　武田　5
10　　11200　　山田　5
11　　4444　　高橋　4
12　　5555　　佐藤　5
13　　6666　　小林　4
14　　7777　　村上　0　　　
15　　空白　　空白　空白　　　←空白の一つ上の行までが抽出したいデータ　
16　　　　　【小計　28】←B列（B16セルに【小計　28】が入っております、値は変わります）
17　　空白　　空白　空白　　
18　30020　南棟１
29　30030　西棟２

Ａ列のコード（30010）(30020)(30030)(30040)・・・(30070)か
Ｂ列の北棟２、南棟１、西棟・・・
を指定し、そこから次の行から空白（空白の前の行まで）をシートに転記できればと考えております。よろしくお願いします。

補足日時：2010/05/29 10:46