EXCEＬ2003 複数シートから抽出したいです

質問

1つのブックに1ヶ月の日数分のシートがあります。（約30シート）
それぞれのシートのデータは、
1水(sheet名)
　　Ａ　Ｂ…　　Ｐ　　　Ｑ　　　Ｒ　　　　Ｓ　
1　　　　　　　りんご　4つ　　300円
2　　　　　　　みかん　3つ　　500円
3　　　　　　　りんご　5つ　　400円
4　　　　　　　バナナ　1つ　　100円
…　　　　　　　…　　　…　　　…

2木(sheet名)
　　Ａ　Ｂ…　　Ｐ　　　Ｑ　　　Ｒ　　　　Ｓ　
1　　　　　　　ぶどう　4つ　　300円
2　　　　　　　みかん　3つ　　500円
3　　　　　　　りんご　2つ　　200円
4　　　　　　　バナナ　1つ　　100円
…　　　　　　　…　　　…　　　…
の様なデータが入力されています。
それぞれ複数のシートのデータの中から、りんごだけを集め集計用のシートに以下の様に表示したいです。
集計用sheet
　　Ａ　　　Ｂ　　　Ｃ　　　Ｄ
1　1水　　りんご　4つ　　300円
2　1水　　りんご　5つ　　400円
3　2木　　りんご　2つ　　200円　　　　　　
4　　　　　　　
…　　…　　　…　　　…

関数でもＶＢＡでもいいので、複数のシートから抽出することは可能でしょうか？
どなたかわかるかた教えて下さい。
よろしくお願いします。

回答No.7

z1rcom · ベストアンサー

今度こそ..大丈夫だと思います。
集計用シート名、検索範囲、結果表示の左上角、検索文字列を編集できます。
例えば、検索文字列に「ぶどう」を追加する場合はこのようになります。
If s(i, 1) = "りんご" Or s(i, 1) = "ぶどう" Then '検索文字列
ここだけは注意して下さい。

Sub りんご抽出コード()

Dim i, j, k, l, m, n, o, y, z, r, t As Long
Dim s, A, B, sn, x As Variant
Dim shn1, shrange As String
Dim p, q As Byte

shn1 = "集計用sheet" '集計用シート名
shrange = "P1:S65536" '検索範囲（全て半角）
wrrange = "B4" '結果表示の左上角

x = Split(shrange, ":") '検索範囲を分割
For q = 0 To 1
For p = 1 To Len(x(q))
If IsNumeric(Mid$(x(q), p, 1)) = False Then
If q = 1 Then y = Mid$(x(0), p + 1) Else: z = Mid$(x(1), p + 1)
End If
Next p
Next q
k = Range(shrange).Columns.Count

ReDim B(Worksheets.Count) 'シート名を取得
For Each sn In Worksheets
i = i + 1: B(i) = sn.Name
Next sn

ReDim A(z - y + 1, k + 1) 'りんごの行を配列に格納
For m = 1 To Worksheets.Count - 1
If B(m) = shn1 Then GoTo 1
s = Sheets(B(m)).Range(shrange)
For i = 1 To z - y + 1
If s(i, 1) = "りんご" Then '検索文字列
j = j + 1: A(j, 1) = B(m)
For l = 1 To k
A(j, l + 1) = s(i, l)
Next l
End If
Next i
1
Next m

With Range(wrrange)
r = .Row - 1: t = .Column - 1
End With
For o = 1 To k + 1 'セルに書き込み
For n = 1 To z - y + 1
If A(n, 1) = "" Then Exit For
Sheets(shn1).Cells(n + r, o + t) = A(n, o)
Next n
Next o

End Sub

回答No.6

merlionXX

回答番号：No.2　です。
「りんご」があるのはP列でいいんですよね？
それなら以下でもう一度お試しください。
P列でないならそう言ってください。

Sub test02()
Dim st As Worksheet
Dim r As Long, x As Long
For Each st In Worksheets
If st.Name <> "集計用" Then
st.Activate
With ActiveSheet
.AutoFilterMode = False
.Rows("1:1").Insert Shift:=xlDown
.Range("A1:S1").AutoFilter
.Range("A1:S1").AutoFilter Field:=16, Criteria1:="りんご"
r = .Cells(Rows.Count, "P").End(xlUp).Row
On Error Resume Next
.Range(.Cells(2, "P"), .Cells(r, "S")).SpecialCells(xlCellTypeVisible).Copy
On Error GoTo 0
x = Sheets("集計用").Cells(Rows.Count, "B").End(xlUp).Row
If x > 1 Then x = x + 1
Sheets("集計用").Cells(x, "A").Value = ActiveSheet.Name
Sheets("集計用").Cells(x, "B").PasteSpecial
Application.CutCopyMode = False
.AutoFilterMode = False
.Rows("1:1").Delete
End With
End If
Next
Sheets("集計用").Activate
End Sub

回答No.5

n-jun

＃１です。

＞しかし、他検索の拡張性はあった方がいいです。
INPUTBOX等で値の取得をして下さい。

あと１行目に項目行はないのかな？
⇒あればAutoFilter等使えそうなんですけど。
それとデータ範囲（列）がわかりにくいのですが。。。

回答No.4

z1rcom

No.3の回答者です。おかしなところがあったので、修正しました。
Sub りんご抽出コード()

Dim i, j, k, l, m, n, o As Long
Dim S, A, B, sn As Variant

ReDim B(Worksheets.Count)
For Each sn In Worksheets
i = i + 1
B(i) = sn.Name
Next sn

k = 3
ReDim A(65536, k)
For m = 1 To Worksheets.Count
If B(m) = "集計" Then GoTo 1
S = Sheets(B(m)).Range("B1:D65536")
For i = 1 To 65536
If S(i, 1) = "りんご" Then
j = j + 1
A(j, 1) = B(m)
For l = 2 To k
A(j, l) = S(i, l)
Next l
End If
Next i
1
Next m

For o = 1 To k + 1
For n = 1 To 65536
If A(n, 1) = "" Then Exit For
With Sheets("集計")
Select Case o
Case 1
.Cells(n, 1) = A(n, 1)
Case 2
.Cells(n, 2) = "りんご"
Case Else
.Cells(n, o) = A(n, o - 1)
End Select
End With
Next n
Next o

End Sub

補足

回答２例ありがとうございます！

上記を試したのですが機能しません…。
実行すると、砂時計マークは表示ているので、計算はしているみたいなのですが、計算結果がなにも表示されません。
なにか問題があるのでしょうか？

下記の方がほぼ完璧に動作しました。
計算スピードも実用性があり、大変満足です。
しかし、もう少し質問があります。
表示用シートに
(1)他シートのPからRでなく、PからSまでを検索したい
(2)検索結果の表示をA1からでなくB4から表示したい

すみませんが宜しくお願いします。

回答No.3

z1rcom

独学なのでおかしなところがあるかもしれませんが、動作確認はしました。

Sub りんご抽出コード()

Dim i As Long, j As Long, k As Long, l As Long, m As Long, _
S As Variant, A As Variant, B As Variant, sn As Worksheet

ReDim B(Worksheets.Count)
For Each sn In Worksheets
i = i + 1
B(i) = sn.Name
Next sn

k = 3 'PからRなので3です。
ReDim A(65536, k)
For m = 1 To Worksheets.Count
S = Sheets(B(m)).Range("P1:R65536")
For i = 1 To 65536
If S(i, 1) = "りんご" Then
j = j + 1
A(j, 1) = B(m)
For l = 2 To k
A(j, l) = S(i, l)
Next l
End If
Next i
Next m

For o = 1 To k
For n = 1 To 65536
If A(n, o) = "" Then Exit For
Sheets("集計").Cells(n, o) = A(n, o)
Next n
Next o

End Sub

回答No.2

merlionXX

Sub test01()
Dim st As Worksheet
For Each st In Worksheets
If st.Name <> "集計用" Then
st.Activate
With ActiveSheet
.AutoFilterMode = False
.Rows("1:1").Insert Shift:=xlDown
.Range(.Range("A2"), .Range("A2").End(xlToRight)).Offset(-1).AutoFilter
.Range(.Range("A2"), .Range("A2").End(xlToRight)).AutoFilter Field:=16, Criteria1:="りんご"
On Error Resume Next
.Range(.Range(.Range("P2"), .Range("P2").End(xlDown)), .Range(.Range("P2"), .Range("P2").End(xlDown)).End(xlToRight)).SpecialCells(xlCellTypeVisible).Copy
On Error GoTo 0
x = Sheets("集計用").Cells(Rows.Count, "B").End(xlUp).Row
If x > 1 Then x = x + 1
Sheets("集計用").Cells(x, "A").Value = ActiveSheet.Name
Sheets("集計用").Cells(x, "B").PasteSpecial
Application.CutCopyMode = False
.AutoFilterMode = False
.Rows("1:1").Delete
End With
End If
Next
Sheets("集計用").Activate
End Sub

補足

回答ありがとうございます。
しかし、
Range(.Range("A2"), .Range("A2").End(xlToRight)).AutoFilter Field:=16, Criteria1:="りんご"
のところでエラーになってしまいます。

回答No.1

n-jun

＞りんごだけを集め集計用のシートに
”りんご”だけでよいのですか。
例えば、次は”みかん”その次は”バナナ”と言う事はないですか。

補足

ありがとうございます。

とりあえずは”りんご”だけでOKです。
しかし、他検索の拡張性はあった方がいいです。