人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセルVBA初心者です。マクロ作成をお願いします。
実績集計のマクロで、条件に従って月毎にデータを集計し、取り込んでいくものです。
各マクロの説明なども入れていただけると助かります。
もしそのまま使える完全な回答をしていただいた回答者の方には500ポイント差し上げます。
よろしくお願いいたします。
※なお、文字制限のため「マクロ実行・集計ファイル」「各月データファイル」は、この下にある「この質問・回答へのコメント」に記載いたします。

●質問者: cane100
●カテゴリ:コンピュータ
✍キーワード:エクセル コメント データ ファイル ポイント
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● airplant
●500ポイント ベストアンサー

マクロでもいいのですが、ExcelのDSUM関数で行ったほうがより分かり易く、条件が少し変わったり増減するときも容易と思います。

操作性はマクロのときとほとんど変わらないと思います。


DSUM関数は、表になったデータから条件にあったものだけを選択して合計する関数です。

詳細は、Excelのヘルプで見てみてください。

なお、コートは文字列、KUBUは数値で入っていると仮定しています。

●手順

Step1.テンプレートとして【当月ファイル】のG1に、数式★Aを貼り付ける(マクロを入れるのと同じイメージです)

Step2.【当月ファイル】のG列に結果(★BのG列)が出るので、それを【年間実績表】のExcelへ貼り付ける(リンク不要なら、数値貼り付け)。サンプルデータは★BのA-E列

以上です。


★A(G1への貼り付け数式)

G H I J K L M N O
1 =DSUM(A1:E65535,"SUJI",H2:K3) 条件1
2 =DSUM(A1:E65535,"SUJI",H5:L7) KUBU KUBU shou koji
3 =DSUM(A1:E65535,"SUJI",H9:J10) =">=10" ="<=29" ="AAA" ="BB?"
4 =DSUM(A1:E65535,"SUJI",H12:J13) 条件2
5 =DSUM(A1:E65535,"SUJI",H15:J18) KUBU KUBU shou koji コート
6 =DSUM(A1:E65535,"SUJI",H20:O21) =">=10" ="<=29" ="<>AAA" ="=1??"
7 =">=10" ="<=29" ="<>BB?" ="=1??"
8 条件3
9 KUBU KUBU コート
10 =">=10" ="<=29" ="=9vv"
11 条件4
12 KUBU KUBU コート
13 =">=10" ="<=29" ="=YYY"
14 条件5
15 KUBU KUBU コート
16 =">=10" ="<=29" ="=9BB"
17 =">=10" ="<=29" ="=9CC"
18 =">=10" ="<=29" ="=9DD"
19 条件6
20 KUBU KUBU コート コート コート コート コート コート
21 =">=10" ="<=29" ="<>9vv" ="<>YYY" ="<>9BB" ="<>9CC" ="<>9DD" ="=9??"

★B(サンプルデータ+結果データ)

A B C D E F G
1 コート koji KUBU shou SUJI 101
2 112 BBx 10 AAA 1 10
3 113 zzz 28 AAA 10 100
4 9vv BBx 29 AAA 100 1000
5 YYY 11 1000 110000
6 9BB BBB 17 10000 1000000
7 9DD 20 AAA 100000
8 9AB 29 1000000
9 9AB 30 10000000

注意1.もし、最初から同じシートになっていたり、リンクして作りたいのであれば、個々のシートに貼り付けずに、【年間実績表】にDSUMを直接書けば大丈夫です。

「シート名!セル範囲」か「[Excelファイル名]シート名!セル範囲」の形式でDSUMを次のように書き換えれば、マクロを動かす前準備をやるだけで一発で結果が出ます。

=DSUM([○○○0806.xls]0806!A1:E65535,"SUJI",H2:K3)

注意2.3000行程度で行ってみましたが、計算にストレスはありませんでした。もし、遅いようなら65536のところを適当に小さくしてみてください。


マクロを組めない訳ではないのですが、関数でできることはできるだけ関数で収めてしまったほうが何かと便利です。

◎質問者からの返答

ありがとうございました。早速試してみたのですが何点か不具合があって悩んでいます。

1.「KUBU」が文字列であったこと。2.「コート」の計算が反映されていないこと。3.年間実績ファイルと当月ファイルが、別の階層・フォルダにあるためか、DSUM関数が上手く機能していないこと。

修正できますでしょうか。よろしくお願い致します。


2 ● Mook
●500ポイント

一応仕様通りに作成してみました。


シート?のシートモジュールに張り付けて実行ください。

シート?の

A1 読み込みファイル名
A2 読み込みファイルの、読み込みシート名
A3 書き込み列名
A4 書き込みシート名

のつもりで使用しています。

仕様に誤解があるようでしたら、コメントください。


Option Explicit

Const COL_COURT = "A"
Const COL_KOJI = "B"
Const COL_KUBU = "C"
Const COL_SHOU = "D"
Const COL_SUJI = "E"

Sub cane100()
 Dim srcWB As Workbook
 Dim srcWS As Worksheet
 Dim dstWS As Worksheet
 Dim dstCol As Long
 Dim dstColName As String

 Dim fso As New FileSystemObject
' Dim fso As Object
' Set fso = CreateObject("Scripting.FileSystemObject")
 
'--- 当月ファイルのチェック
 If fso.FileExists(Range("A1").Value) = False Then
 MsgBox Range("A1").Value & "がありません"
 Exit Sub
 End If

 Set srcWB = Workbooks.Open(Range("A1").Value)
 If srcWB Is Nothing Then
 MsgBox Range("A1").Value & "が開けませんでした。"
 Exit Sub
 End If
 
'--- 当月ファイルのシート名のチェック
 On Error Resume Next
 Set srcWS = srcWB.Worksheets(Range("A2").Value)
 On Error GoTo 0
 
 If srcWS Is Nothing Then
 MsgBox "シート[" & Range("A2").Value & "]がありません。"
 Exit Sub
 End If

'--- 年間実績ファイルのシート名のチェック
 On Error Resume Next
 Set dstWS = ThisWorkbook.Worksheets(Range("A4").Value)
 On Error GoTo 0

 If dstWS Is Nothing Then
 MsgBox "シート[" & Range("A4").Value & "]がありません。"
 Exit Sub
 End If
 
'--- 年間実績シートの出力列のチェック
 Dim dstRange As Range
 dstColName = Range("A3").Value
 Set dstRange = dstWS.Rows(1).Find(dstColName)
 
 If dstRange Is Nothing Then
 If MsgBox("列[" & Range("A3").Value & "]がありません。最終列に追加しますか?", vbYesNo) = vbNo Then
 Exit Sub
 End If
 If dstWS.Cells(1, Columns.Count).Value <> "" Then
 MsgBox "最終列までデータがあります。"
 Exit Sub
 End If
 dstCol = dstWS.Cells(1, Columns.Count).End(xlToLeft).Column + 1
 dstWS.Cells(1, dstCol) = Range("A3").Value
 Else
 dstCol = dstRange.Column
 End If

 Dim lastRow As Long
 lastRow = srcWS.Range(COL_SUJI & Rows.Count).End(xlUp).Row
 Dim srcRow As Long
 Dim sum(6) As Long '--- とりあえずロング型:必要に応じてDouble へ
 
'--- 各条件の集計
 With srcWS
 For srcRow = 2 To lastRow
 If CheckKubu(.Cells(srcRow, COL_KUBU).Value) Then
 If CheckCondition1(.Cells(srcRow, COL_SHOU), .Cells(srcRow, COL_KOJI)) Then
 sum(1) = sum(1) + .Cells(srcRow, COL_SUJI).Value
 Else
 If CheckCondition2(.Cells(srcRow, COL_COURT)) Then
 sum(2) = sum(2) + .Cells(srcRow, COL_SUJI).Value
 End If
 End If
 Select Case .Cells(srcRow, COL_COURT).Value
 Case "9vv"
 sum(3) = sum(3) + .Cells(srcRow, COL_SUJI).Value
 Case "YYY"
 sum(4) = sum(4) + .Cells(srcRow, COL_SUJI).Value
 Case "9BB", "9CC", "9DD"
 sum(5) = sum(5) + .Cells(srcRow, COL_SUJI).Value
 Case Else
 If Left(.Cells(srcRow, COL_COURT).Value, 1) = "9" _
 And Len(.Cells(srcRow, COL_COURT).Value) = 3 Then
 sum(6) = sum(6) + .Cells(srcRow, COL_SUJI).Value
 End If
 End Select
 End If
 Next
 End With

'--- 結果の出力
 Dim resRow As Long
 For resRow = 2 To 7
 dstWS.Cells(resRow, dstCol).Value = sum(resRow - 1)
 Next
 dstWS.Activate
End Sub

'--- KUBU のチェック
Function CheckKubu(num) As Boolean
 CheckKubu = False
 If IsNumeric(num) = False Then
 Exit Function
 End If
 
 If num >= 10 And num <= 29 Then
 CheckKubu = True
 End If
End Function

'--- 条件?のチェック
Function CheckCondition1(shou As Variant, koji As Variant) As Boolean
 If shou.Value = "AAA" And Left(koji.Value, 2) = "BB" And Len(koji.Value) = 3 Then
 CheckCondition1 = True
 Else
 CheckCondition1 = False
 End If
End Function
 
'--- 条件?のチェック
Function CheckCondition2(court As Variant) As Boolean
 If Len(court.Value) = 3 And Left(court.Value, 1) = "1" Then
 CheckCondition2 = True
 Else
 CheckCondition2 = False
 End If
End Function
関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ