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

質問

質問：特定文字列から空白行までの抽出
お世話になります、ネットで公開されている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 · ベストアンサー

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) & "*")　の"*"や所々解らない部分もありますが、助かりました
ありがとう御座います。

回答No.5

n-jun

＃２です。

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

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

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

お礼

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

回答No.4

kmetu

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へそれぞれデータを貼り付けたいと思っております。
頼り過ぎて申し訳ありません。

回答No.3

kmetu

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

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へそれぞれデータを貼り付けたいと思っております。よろしくお願いします。

回答No.1

n-jun

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

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

と判断しました。

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)か
Ｂ列の北棟２、南棟１、西棟・・・
を指定し、そこから次の行から空白（空白の前の行まで）をシートに転記できればと考えております。よろしくお願いします。