Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10全般 : Excel 2016)
指定した2つの品名を変更し、その合計を求めたい
投稿日時: 19/05/07 10:56:25
投稿者: いわちゃん

いつも参考にさせてもらっている初心者です。 相談させてください。
 
やりたい事は、
シート1にあるデータ C列に特定の品名「リンゴ」、「ブドウ」があった場合、品名を「フルーツ」にし合計を足したものをシート2に出したい。
 
 
A列:部署
B列:名前
C列:品名
D列:合計
 
[シート1]
1課 田中 キャベツ 10
1課 田中 リンゴ 5
1課 田中 ブドウ 3
1課 田中 ニンジン 2
1課 田中 玉ねぎ 1
1課 鈴木 リンゴ 4
1課 鈴木 ブドウ 1
1課 鈴木 とまと 2
1課 鈴木 玉ねぎ 10
 
[シート2]
1課 田中 キャベツ 10
1課 田中 フルーツ 8
1課 田中 ニンジン 2
1課 田中 玉ねぎ 1
1課 鈴木 フルーツ 5
1課 鈴木 とまと 2
1課 鈴木 玉ねぎ 10
 
色々調べたのですが、やり方が全くわからず手作業でやっています。
ご教示お願いします。

回答
投稿日時: 19/05/07 13:56:20
投稿者: Suzu

シート1の E列にてでも作業列を持ち、その作業列では、
IF関数を使用し、【リンゴ】【ブドウ】の場合【フルーツ】を返すようにすればよいのでは?

投稿日時: 19/05/07 14:32:35
投稿者: いわちゃん

Suzuさん、ありがとうございます。
 
前の作業でもマクロを使用しており、手作業を省きたいです。
勉強中でもあり、マクロでご教示いただけると助かります。
よろしくお願いします。

回答
投稿日時: 19/05/07 16:07:08
投稿者: sk

引用:
Windows 10全般 : Excel 2016

引用:
シート1にあるデータ C列に特定の品名「リンゴ」、「ブドウ」があった場合、
品名を「フルーツ」にし合計を足したものをシート2に出したい。

・その Excel ブックのファイル形式が何であるか。
 ( .xls, .xlsx, .xlsm など)
 
・その実行環境に Access 2016、または Microsoft Access データベースエンジンが
 インストールされているか否か。
 
以上の条件次第かと。

投稿日時: 19/05/07 16:33:46
投稿者: いわちゃん

skさん、ありがとうございます。
 
形式は、xslmです。
 
Accessは、使用しないので、インストールされていません。
インストールされてないと、質問したことは実行できないのでしょうか???
(無知ですいません。汗)

投稿日時: 19/05/07 16:35:17
投稿者: いわちゃん

いわちゃん さんの引用:
skさん、ありがとうございます。
 
形式は、xslmです。

 
申し訳ありません。
xlsm です。
 

回答
投稿日時: 19/05/07 17:14:25
投稿者: sk

引用:
xlsm です。

引用:
Accessは、使用しないので、インストールされていません。

(標準モジュール)
-------------------------------------------------------------
Public Sub subCreateSummarySheet()
On Error GoTo Err_subCreateSummarySheet
     
    Dim objCN As Object 'ADODB.Connection
    Dim objRS As Object 'ADODB.Recordset
             
    Dim wsDestination As Excel.Worksheet
             
    Dim strFilePath As String
    Dim strConnectString As String
    Dim strSQL As String
    Dim lngColumn As Long
             
    strFilePath = ThisWorkbook.FullName
             
    Set objCN = CreateObject("ADODB.Connection")
     
    With objCN
        .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                            "Data Source=" & strFilePath & ";" & _
                            "Extended Properties=""Excel 8.0;HDR=YES"""
        .Open
    End With
 
    strSQL = "SELECT " & _
             " t1.[部署]" & _
             ", t1.[名前]" & _
             ", IIf(t1.[品名] In ('リンゴ','ブドウ'),'フルーツ',t1.[品名]) AS [品名]" & _
             ", Sum(t1.[合計]) AS [合計]"
     
    strSQL = strSQL & _
             " FROM [シート1$] t1"
     
    strSQL = strSQL & _
             " GROUP BY " & _
             " t1.[部署]" & _
             ", t1.[名前]" & _
             ", IIf(t1.[品名] In ('リンゴ','ブドウ'),'フルーツ',t1.[品名])"
 
    strSQL = strSQL & _
             " ORDER BY " & _
             " t1.[部署]" & _
             ", t1.[名前]" & _
             ", IIf(t1.[品名] In ('リンゴ','ブドウ'),'フルーツ',t1.[品名])"
 
    Set objRS = CreateObject("ADODB.Recordset")
     
    With objRS
        Set .ActiveConnection = objCN
        .Source = strSQL
        .CursorLocation = 3 'adUseClient
        .LockType = 1 'adLockReadOnly
        .CursorType = 3 'adOpenStatic
        .Open
    End With
         
    Set wsDestination = ThisWorkbook.Worksheets("シート2")
     
    Application.ScreenUpdating = False
    With wsDestination
        '全セルのクリア
        .Cells.Clear
        '列見出し行の設定
        For lngColumn = 0 To objRS.Fields.Count - 1
            .Cells(1, lngColumn + 1).Value = objRS.Fields(lngColumn).Name
        Next
        'レコードセットの出力
        .Cells(2, 1).CopyFromRecordset objRS
        'ワークシートをアクティブに
        .Activate
        .Cells(1, 1).Select
    End With
    Application.ScreenUpdating = True
         
    MsgBox "実行完了", vbInformation, "subCreateSummarySheet"
 
Exit_subCreateSummarySheet:
On Error Resume Next
 
    Set wsDestination = Nothing
     
    objRS.Close
    Set objRS = Nothing
    objCN.Close
    Set objCN = Nothing
         
    Exit Sub
 
Err_subCreateSummarySheet:
 
    Application.ScreenUpdating = True
 
    MsgBox Err.Number & ": " & Err.Description, _
           vbCritical, _
           "実行時エラー(subCreateSummarySheet)"
     
    Resume Exit_subCreateSummarySheet
End Sub
-------------------------------------------------------------
(ワークシート名に当たる箇所は適宜修正すること)
 
とりあえず、以上のコードの実行結果を確認してみて下さい。

回答
投稿日時: 19/05/07 20:21:24
投稿者: mattuwan44

引用:
色々調べたのですが、やり方が全くわからず手作業でやっています。

 
手作業で出来るなら、その作業をVBAを使って自動で実行できるよう、
「マクロ化」したらいいのでは?
 
パット思いつく感じでは、
 
1)シート1をシート丸ごとコピー
2)新しくできたシートの「りんご」を「フルーツ」に置換
3)新しくできたシートの「ぶどう」を「フルーツ」に置換
4)ピボットテーブルでさらに新しいシートに集計
5)ピボットテーブルの結果をシート2にコピペ
6)手順1,4で作ったシートを削除
 
で、希望する結果になると思いますが、いかがでしょうか?
 
手順が確立されれば、あとは「マクロの記録」でコードを探り、
不要な部分は削除、必要な物は追記するなどして
整理し、使えるマクロを作ります。

回答
投稿日時: 19/05/07 20:38:21
投稿者: mattuwan44

追記
 
作業用の列や作業用のシートに途中経過を出力すると、
結果を出すまでの流れが簡単になります。
数式案も出てます。そちらでも問題ないと思います。
自動でやるのだから、後で消せば、使う側にはどうやって結果を出したかわかりませんし、
使う側はどうやって結果を出しているのかを気にすることはないですし、
どうやって結果を出しているか気にする必要もありません。
 
処理速度に不満が出てきたら、その時に別の手順を模索したらいいと思います。
 
勉強も目的なら、たくさんのコードを書いてみることも肝要かと思います。
まずは、書いてみましょう。で、そのうえで別案等のアイデアを求めて、
いろんなコードを見ましょう。(他の方の質問等も見てみましょう。)

回答
投稿日時: 19/05/07 20:40:53
投稿者: simple

その修正は、性格としては、入力の修正なんですか?
それとも、集計レベルを1段階上げるという定常的に発生する処理なんですか?
 
・後者なら、すでに指摘のあったピボットテーブルが良いと思いますし、
・前者なら、オートフィルタを使って手作業でするのがよいと思いますよ。
  いつも起きるものでなければ、
  その都度マクロを作るより、手作業のほうが実際的でしょう。
  自分で理解できる範囲のものにしておいたほうが間違いないでしょう。
 他人の回答すらきちんと確認できないんですから。

投稿日時: 19/05/08 08:09:14
投稿者: いわちゃん

mattuwan44さん、skさん、ありがとうございます。
skさんが教えてくださったコードと、mattuwan44さんのアドバイスくださった手作業もマクロ化でよく考えてみます。
 
 
simpleさん、ありがとうございます。(手作業を省きたいので質問させていただいるので、よく質問読んでいただけると助かります(^^;))