Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

55143 / 76732

←次へ　｜　前へ→


	【26368】効率的なコードにするには…。

あさみ - 05/7/2(土) 23:54 -


	引用なし

	パスワード

はじめまして。あさみと申します。
db.xls（データベース）から、条件に当てはまるセルの集計を、d.xls（集計表）に反映させたいと考えています。

何とか自分の力で…！と思い、色々な本やサイトを参考にしてみたのですが、自分で考えた方法では、あまりにも処理時間がかかるので、もうすこし効率的なコードにならないかなと思い、こちらに質問させていただきました。

長々ともうしわけありませんが、下記にデータベースの内容と、コードを記入させていただきましたので、有志の皆様、是非お力をおかしください…！

また、下記に記入させていただいたコードは、db.xlsとd.xlsともに、("2005.6")用になっていて、できれば同じコードを使い、Worksheets名を("2005.7")に変えて流用できれば…と思うのですが、思うように反映されません…。
何か良い方法がありましたら、是非ご教授くださいませ。

よろしくお願いいたします。

【Book1（データベース）】
　　A　　　B　　　　　C　　 D
1　得意先　営業部門　商品　受注総額
2　AAA　　　　　京都　　　　　　○　　　　 100
3　AAA　　　　　京都　　　　　　■　　　　 200
4　AAA　　京都　　　　　　△　　　　 300
5　AAA　　　　　大阪　　　　　　○　　　　 400
6　AAA　　　　　大阪　　　　　　■　　　　 500
7　AAA　　　　　大阪　　　　　　△　　　　 500
8　AAA　　　　　神戸　　　　　　○　　　　 400
9　AAA　　　　　神戸　　　　　　■　　　　 300
10 AAA　　　　　神戸　　　　　　△　　　　 200
11 BBB　　　　　京都　　　　　　○　　　　 100
12 BBB　　　　　京都　　　　　　■　　　　 600
13 BBB　　　　　京都　　　　　　△　　　　 700
14 BBB　　　　　大阪　　　　　　○　　　　 800
15 BBB　　　　　大阪　　　　　　■　　　　 900
（以下続く）

【コード】
'2005.6
Sub 得意先AAAデータ取得6()
''ブック＆シート指定
　　Dim wbs As Worksheet
　　Dim destination As Worksheet
　　Application.ScreenUpdating = False
　　Set wbs = Workbooks.Open(“C:\Documents and Settings\質問\db.xls").Worksheets("2005.6")
　　Set destination = Workbooks("d.xls").Worksheets("2005.6")
　　
''AAA&京都&○
With Range("D1")
.AutoFilter
.AutoFilter Field:=1, Criteria1:="AAA"
.AutoFilter Field:=2, Criteria1:="京都"
.AutoFilter Field:=3, Criteria1:="○"
End With
Range("D84").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[-82]C:R[-1]C)"
　　　
コピペ6 wbs.Range("D84"), destination.Range("B3")

''AAA&大阪&○
With Range("D1")
.AutoFilter
.AutoFilter Field:=1, Criteria1:="AAA"
.AutoFilter Field:=2, Criteria1:="大阪"
.AutoFilter Field:=3, Criteria1:="○"
End With
Range("D84").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[-82]C:R[-1]C)"
　　　
コピペ6 wbs.Range("D84"), destination.Range("C3")

''AAA&神戸&○
With Range("D1")
.AutoFilter
.AutoFilter Field:=1, Criteria1:="AAA"
.AutoFilter Field:=2, Criteria1:="神戸"
.AutoFilter Field:=3, Criteria1:="○"
End With
Range("D84").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[-82]C:R[-1]C)"
　　　
コピペ6 wbs.Range("D84"), destination.Range("D3")

''AAA&京都&■
With Range("D1")
.AutoFilter
.AutoFilter Field:=1, Criteria1:="AAA"
.AutoFilter Field:=2, Criteria1:="京都"
.AutoFilter Field:=3, Criteria1:="■"
End With
Range("D84").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,R[-82]C:R[-1]C)"
　　　
コピペ6 wbs.Range("D84"), destination.Range("B4")

（中略）

''作業後に参照元シートを閉じる
wbs.Parent.Close False
Application.ScreenUpdating = True
Set wbs = Nothing
Set destination = Nothing
End Sub

Private Sub コピペ6(ByVal コピー元 As Range, ByVal コピー先 As Range)
　　コピー元.Copy
　　コピー先.PasteSpecial Paste:=xlPasteValues
　　Application.CutCopyMode = False
End Sub

本当に長々ともうしわけありません。
よろしくお願いいたします。

0 hits

▼

【26368】効率的なコードにするには…。 あさみ 05/7/2(土) 23:54

≪