VBAエクセル、項目検索からデータ抽出

質問

お世話になります。早速ですがsheets("データ元").Range("A2")にNo.、Range("B2")に日付、Range("C2")に曜日、Range("D2")に項目、Range("E2")に詳細、Range("F2")に金額があり
A3～F3以下LastRowまでデータが入っています。
Range("D3"）以下LastLowの中から１会社名を検索するとその会社名すべてのデータが新規ブックSheet1に書き出され、そのシートのRange("G3")に合計額を出す構文をどなたかご教示ください宜しくお願いします。エクセル２００３と２０１３を各パソコンで使用しています。

回答No.3

mt2015 · ベストアンサー

AdvancedFilterでやってみました。
＃確認はExcel2010でしかやっていません。

Sub Sample()
'新規ブック追加
Workbooks.Add
'抽出条件を新規ブックに仮作成
　　Range("H1") = ThisWorkbook.Sheets("データ元").Range("D2")
　　Range("H2") = "会社名"　'←抽出する会社名
　　sNewBook = ActiveWorkbook.Name

　　'AdvancedFilterで抽出
　　With ThisWorkbook.Worksheets("データ元")
　　　　nLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
　　　　.Range("A2:F" & nLastRow).AdvancedFilter _
　　　　　　Action:=xlFilterCopy, _
　　　　　　CriteriaRange:=Workbooks(sNewBook).Sheets("Sheet1").Range("H1:H2"), _
　　　　　　CopyToRange:=Workbooks(sNewBook).Sheets("Sheet1").Range("A2")
　　End With

　　'新規ブックの抽出条件を消して、合計金額を入れる
　　With Workbooks(sNewBook).Sheets("Sheet1")
　　　　.Range("H1:H2").Clear
　　　　.Range("G3") = WorksheetFunction.Sum(Range("F:F"))
　　End With
End Sub

お礼

できました有難うございます。 少し触らせていただきましたごめんなさい、感謝しています
'新規ブック追加
Workbooks.Add
'抽出条件を新規ブックに仮作成
Range("H1") = ThisWorkbook.Sheets("データ元").Range("D2")
Range("H2") = InputBox("") '←抽出する会社名
sNewBook = ActiveWorkbook.Name

'AdvancedFilterで抽出
With ThisWorkbook.Worksheets("データ元")
nLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("A2:F" & nLastRow).AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=Workbooks(sNewBook).Sheets("Sheet1").Range("H1:H2"), _
CopyToRange:=Workbooks(sNewBook).Sheets("Sheet1").Range("A2")
End With

'新規ブックの抽出条件を消して、合計金額を入れる
With Workbooks(sNewBook).Sheets("Sheet1")
.Range("H1:H2").Clear
.Range("G3") = WorksheetFunction.Sum(Range("F:F"))
End With
Sheets("Sheet1").Columns("A:F").EntireColumn.AutoFit

回答No.7

ushi2015

No1です。
会社 = "１会社名"
の"１会社名"の部分にInqutBoxの値を
セットしましたか？

お礼

有難うございました。感謝です

補足

やってみましたが結果は同じです。ほかの方も教示を待っていると思いますので、また回答No.３のmt2015 さまのマクロで動作していますのでそちらを組み込んでいこうと思います。長いことお付き合いさせてしまってごめんなさい。

回答No.6

imogasi

#2です。＃２で書いた４つのロジックのほかにもう一つ思い出したので書いておきます。
あくまでそういう方法もあるということ。
紙の表があってコンピュターがない時代は、下記のような手順でやっていたと思う。
小生は昔、表を１行＝社ずつカッターで切り離し、その会社だけを別にして、、別の白紙にその会社分だけ張り付けていたこともある。それをコンピュターでやったもの。
（５）ソート法
データを注目している検索データのある列でソート。
望む該当の初出行をＦｉｎｄメソッドで見つけ、件数をＣｏｕｎｔｉｆ関数で見つけ、
その範囲をＳｈｅｅｔ２にコピー貼り付けする。
例データ　ソート後 Sheet1(ソート前は本当はバラバラのデータ）
会社 計数
aa 1
aa 5
aa 4
aa 6
b 3
b 1
b 2
b 2
c 22
c 3
d 3
f 44
s 2
v 11
x 5
標準モジュールに
Sub Macro1()
Worksheets("Sheet1").Range("A1").Select
lr = Range("A10000").End(xlUp).Row
'---
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A2:B" & lr) 'データ範囲。
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'--以上ソートのマクロの記録をそのまま参考にすした
lr = Range("A10000").End(xlUp).Row
'MsgBox ”データ最終行=" & lr
Set x = Worksheets("Sheet1").Range("A1:B" & lr).Find("b") 'bに探している会社名などを指定
xr = x.Row
MsgBox "最初行=" & xr 'x.Address
k = WorksheetFunction.CountIf(Worksheets("Sheet1").Range("A1:B" & lr), "b")
MsgBox "bの存在行数・件数=" & k
Worksheets("Sheet1").Range("A" & xr & ":B" & (xr + k - 1)).Select
Selection.Copy Worksheets("Sheet2").Range("a2")
End Sub
実行後　結果　Sheet2
b 3
b 1
b 2
b 2

お礼

有難うございました。

補足

エラーが出ますがどのあたりでと聞かれても答えられません、ごめんなさいこの数式は諦めます。

回答No.5

ushi2015

No1です。
　　　nBk.SaveAs _
　　　　Filename:=dBk.Path & "\集計" & Format(Now(), "yyyymmdd hhmmss") & ".xls", _
　　　　FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
　　　　ReadOnlyRecommended:=False, CreateBackup:=False
を
　　　nBk.SaveAs _
　　　　Filename:=dBk.Path & "\集計" & Format(Now(), "yyyymmdd hhmmss") & ".xls", _
　　　　FileFormat:=56, Password:="", WriteResPassword:="", _
　　　　ReadOnlyRecommended:=False, CreateBackup:=False
　　　　nBk.Close

と差し替えて実行してみて下さい。

お礼

有難うございます。

補足

差し替えましたが、今度は対象データ無しとなります。私の説明不足だと思うのですが、sheets("データ元").Range("A2")にNo.、Range("B2")に日付、Range("C2")に曜日、Range("D2")に項目、Range("E2")に詳細、Range("F2")に金額。
以下A3～F3各LastRowまでデータが入っています。
Range("D3"）以下LastLowの中から会社名をインプットボックスに入力するとRange("D3")以下のデータの中から入力された会社のデータすべてがWorkBooks.AddのSheets("Sheet1"）に書き出すようにしたいのですが...

回答No.4

imogasi

#２の補足のことだが、Ｐｉｖｏｔを使う方法もマクロの記録を取って、適当に変更部分を
自由にする変更をしたり、結果を印刷することもできるよ。
だいたい、ここに丸投げ的に質問するまでもなく、フィルター法などは、マクロの記録を取ればＶＢＡコードがわかるはず。マクロの記録という方法があるのは知っているだろうね。

お礼

ご指摘有難うございます、感謝しています

回答No.2

imogasi

ＶＢＡでも、4つぐらい方法が考えられる。関数でもできるが（略）。
総なめ法
（１）第2行からＬａｓｔＬｏｗまで1行づつ、会社名（第何列か？Ｎｏは会社のＮＯか？質問にはっきり書くこと）を判別し、一致したものは書き出すとか金額を足しこむ。全会社について行うなら、会社ＮＯを配列に出も持って、その会社該当の配列要素に金額を足しこむ。
Ｆｉｎｄ法
（２）第2行からＬａｓｔＬｏｗまで会社名で可視社名のある列でデータを探し、見つかった行で書き出すか金額を足しこむ。
Ｆｉｌｔｅｒ法
（３）会社名でフィルタして、金額合計を出す
ＰＩＶＯＴＴａｂｌｅ法
（４）ピボットテーブルでＮｏごとに表を作れば、前者の合計データが出る。明細も出せる。会社の限定・任意選択も操作で容易。
（４）は操作が便利だが、マクロの記録やＶＢＡのPivottabls.Addでできる。
元データ
会社ＮＯ 金額
1　 1
2　　2
4　 1
5　 3
2　 2
3　 5
6　 6
1　 1
2　 2
とする。
挿入ーピボットテーブルーＯＫ
行へＮＯ、Σ値へ金額をそれぞれＤ＆Ｄ
結果
行ラベルをクリックして、２，６をチェック
結果
2,6だけフィルタされて
行ラベル 合計 / 金額
2 6
6 6
総計 12
明細を出したかったら
仮に空き列に行番号を振って
会社ＮＯ 金額 行　行番号
1 1 1
2　 2　 2
4　 1　 3
5　 3　 4
2　 2　 5
3　 5　 6
6　 6　 7
1　 1　 8
2　 2　 9
行に会社NO次に行番号をD&D、Σ値に金額をD&D
ピボットでやりだしたら、VBAでやるなど「ちゃんちゃら」手数がかかる。

お礼

有難うございました

補足

ご指摘有難うございます。Noは行番号です、ピボットのご教示有難うございます。今回はピボット抜きの作成を考えています、ワンクリックで印刷まで持っていきたいからです。

回答No.1

ushi2015

こんにちは
Sub test()
　　Dim dBk As Workbook
　　Dim dSh As Worksheet
　　Dim nBk As Workbook
　　Dim 会社 As String

　　Set dBk = ThisWorkbook
　　Set dSh = dBk.Worksheets("データ元")
　　Set nBk = Workbooks.Add

　　会社 = "１会社名"

　　With dSh
　　　　.AutoFilterMode = False
　　　　With .Range("A2:F" & .Range("A" & Rows.Count).End(xlUp).Row)
　　　　　　.AutoFilter Field:=4, Criteria1:=会社
　　　　　　With .SpecialCells(xlCellTypeVisible)
　　　　　　　　If .Rows.Count > 1 Then
　　　　　　　　　　.Copy nBk.Worksheets("Sheet1").Range("A2")

　　　　　　　　　　With nBk.Worksheets("Sheet1").Range("G2")
　　　　　　　　　　　　.Formula = "=SUBTOTAL(9,F:F)"
　　　　　　　　　　　　.Value = .Value
　　　　　　　　　　End With

　　　　　　　　　　nBk.SaveAs _
　　　　　　　　　　　　Filename:=dBk.Path & "\集計" & Format(Now(), "yyyymmdd hhmmss") & ".xls", _
　　　　　　　　　　　　FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
　　　　　　　　　　　　ReadOnlyRecommended:=False, CreateBackup:=False
　　　　　　　　Else
　　　　　　　　　　MsgBox "対象データ無し"
　　　　　　　　　　nBk.Close False
　　　　　　　　End If
　　　　　　End With
　　　　End With
　　　　.AutoFilterMode = False
　　End With
End Sub
こんな感じでしょうか？

お礼

ご教示有難うございます。（尚、エラーは実行時エラー1004　SaveAsメソッドは失敗しました。ワークブックオブジェクトです。）

補足

nBk.SaveAs _
Filename:=dBk.Path & "\集計" & Format(Now(), "yyyymmdd hhmmss") & ".xls", _
FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
有難うございます上記でエラーが出ます２０３，２０１３共。宜しくお願いします