エクセルVBA初心者です。マクロ作成をお願いします。

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

回答の条件
  • 1人5回まで
  • 登録:2008/06/21 00:12:38
  • 終了:2008/06/26 23:34:20

ベストアンサー

id:airplant No.1

airplant回答回数220ベストアンサー獲得回数492008/06/21 03:52:28

ポイント500pt

マクロでもいいのですが、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のところを適当に小さくしてみてください。


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

id:cane100

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

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

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

2008/06/23 20:38:29

その他の回答(1件)

id:airplant No.1

airplant回答回数220ベストアンサー獲得回数492008/06/21 03:52:28ここでベストアンサー

ポイント500pt

マクロでもいいのですが、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のところを適当に小さくしてみてください。


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

id:cane100

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

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

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

2008/06/23 20:38:29
id:Mook No.2

Mook回答回数1312ベストアンサー獲得回数3912008/06/22 01:34:52

ポイント500pt

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


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

シート①の

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
  • id:cane100
    ~詳細です~

    ■【集計マクロ&年間実績ファイル】

    ~シート①【マクロ実行】


    ↓  →A(エクセル列)
    1 【当月ファイル】データパス名(\\○○○0806.xls)←毎月入力
    2 シート名(0806)←毎月入力
    3 入力対象月(年間実績シートの入力列)←毎月入力
    4 年間実績シート←出力先

    ※①毎月マクロ実行前に、上記パス名、シート名を全て入力(変更)②マクロボタンをクリック
    ③マクロ画面を保存し、終了

    ※処理内容・・・各条件に従って集計し、【当月ファイル】から年間実績シートの指定月へ「SUJI」を書き込む。
    最後は、各ファイルは開いたままでOK。

    ~シート2【年間実績表】
          4月     5月      6月     7月   8月・・・・・
    条件①「SUJI」を集計「SUJI」を集計 「SUJI」を集計
    条件②   〃       〃      〃
    条件③   〃       〃      〃
    条件④   〃       〃      〃
    条件⑤   〃       〃      〃
    条件⑥   〃       〃      〃

    ※条件について
    全てに通じる条件・・・「KUBU」が「10~29」まで
    条件①・・・「shou」が「AAA」で、且つ「koji」が「BB?」の全ての「SUJI」
    条件②・・・条件①以外で、「コート」が「1??」の全ての「SUJI」
    条件③・・・「コート」が「9vv」の全ての「SUJI」
    条件④・・・「コート」が「YYY」の全ての「SUJI」
    条件⑤・・・「コート」が「9BB」「9CC」「9DD」の全ての「SUJI」
    条件⑥・・・条件③~⑤以外で、「コート」が9??の全ての「SUJI」


    ■当月ファイル
          A   B   C    D   E   ←(列)
    1    「コート」「koji」「KUBU」「shou」「SUJI」 

    2     2行目以下、それぞれデータが約2500行目まで




    (行)






  • id:Mook
      Dim fso As New FileSystemObject
    ' Dim fso As Object
    ' Set fso = CreateObject("Scripting.FileSystemObject")
    を元に戻すのを忘れていました。

    VBE の ツール⇒参照設定 で 「MicroSoft Scripting Runtime」を選択するか、
    '  Dim fso As New FileSystemObject
      Dim fso As Object
      Set fso = CreateObject("Scripting.FileSystemObject")
    に変更してお試しください。
  • id:cane100
    変更内容が分からないのですが、何を何に変更したらよいのでしょうか。本当に初心者で申し訳ありません。
  • id:Mook
    コードの上から12行目あたりに、

      Dim fso As New FileSystemObject
    '  Dim fso As Object
    '  Set fso = CreateObject("Scripting.FileSystemObject")

    と書かれていますので、行の先頭のコーテーション(')を

    '  Dim fso As New FileSystemObject
      Dim fso As Object
      Set fso = CreateObject("Scripting.FileSystemObject")

    のように、逆にして下さい。
    ' は コメントの意味なので、これ以降はプログラムとして動作しません。
  • id:cane100
    早速ありがとうございました。試してみたのですが、「コンパイルエラー End subが必要です」とのエラーメッセージが、冒頭部分で出てしまいました。
  • id:airplant
    1.「KUBU」が文字列であったこと。
    DSUMは、文字列は大小関係見られないようなので、もし1桁目が数字のみであれば、次のように書き換えれば、大丈夫です
    =">=10" → ="=1?", 29のところも同じように変更ください。

    2.「コート」の計算が反映されていないこと。
    「計算が反映されていない」の意味が良く分かりませんが、集計でピックアップされてこないということでしょうか?
     もしそうならば、上記のKUBUが一致していないので、結果は0になります。そういう意味でしょうか?
    もしくは、コートが文字型と数字型が混在しているとうまくいきません。

    全部の型を揃えるには新たな列で次のようにすればできます。
    全部文字にする: =A1&""
    全部数字にする: =A1+0

    3.年間実績ファイルと当月ファイルが、別の階層・フォルダにあるためか、DSUM関数が上手く機能していないこと。
    先ずは、上記1、2のことを解決してからのことと思います。
    同一シート内ではうまくいきますでしょうか?

    ちなみに、別フォルダのブックを参照するときには、リンク貼り付けなどでやってみればわかりますが、次のような参照になります。
    この形式にしておけば、別フォルダでも問題なくセルの参照できます。
    'C:\フォルダ名称\[xxxxx.xls]Sheet1'!A1

    1ヶ月に1度でかつ条件も結構変わるようなので、マクロにせず、同じシートに作ってから、それを貼り付けで十分と思うのですが、いかがでしょうか?
  • id:cane100
    ありがとうございました。書き換えて問題解決です。心から感謝いたします。今後ともよろしくお願い致します。
  • id:cane100
    MOOKさん、マクロありがとうございました。お作りいただいたマクロ、もう少し勉強させていただきます。また分からない点が出てきましたらよろしくお願い致します。
  • id:Mook
    あまりお役にたたなかったようですが、過分なポイントありがとうございました。

    不明な点がありましたら、ご質問ください。
  • id:airplant
    レス遅れました。すみませんでした。
    たくさんのポイント、ありがとうございます。

    要はトータルで楽になる方法がいいですね。
    シート関数とマクロ、それぞれの使い場所があると思うので、それに合わせて、人間が機械を使うようにすればいいのだと思います。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません