[[20211130054219]] 『VBA計算&シート生成』(リカオン) >>BOT

[ 初めての方へ | 一覧(最新更新順) |

| 全文検索 | 過去ログ ]

 

『VBA計算&シート生成』(リカオン)

知能が足りず、途中でつまずいております。
下記のサンプルコードをいただきたいです。
シートAに記載されている社員全員分(社員番号を基準)、商品タイプ別の価格をシートBに出力して、シートBの生成を繰り返したいです。
例えば、池田でしたらSampleの合計価格、B品の合計価格をシートBに出力し、シート保存。そして葛籠に移行。社員全員分のシート生成を繰り返したいです。
よろしくお願いいたします。

シートA
A__________B___________C___________D_________E_______F_______
社員番号___氏名_________Item________Qty_______価格____商品タイプ
125_______平松_________DRESS______1_________1000 __Sample
123_______池田_________BELT________1_________2000___Sample
126_______葛籠_________SKIRT_______1_________1500___Sample
123_______池田_________SHIRT_______1_________2000___B品
127_______藤田_________SKIRT_______1_________3000___Sample

シートB
A_____B__________________C__________
1_____社員番号___________氏名_________
2_____Sampleの合計価格__B品の合計価格

< 使用 Excel:Office365、使用 OS:Windows2000 >


https://www.239-programing.com/cgi-bin/excelvba_bbs.cgi
(MANAN) 2021/11/30(火) 06:58

>下記のサンプルコードをいただきたいです。
ただの丸投げでしょうか?
やりたいことを拝見するに2行目?から順番に
 (1)新しい【ブック】を追加する
 (2)(1)のブックの1番目のシートに出力(書き込みやコピペ)する
 (3)(2)ブックを名前を付けて保存する
 (4)(3)のブックを閉じる

という処理を繰り返せばよいのではありませんか?
繰り返し処理はともかく、そのほかは【マクロの記録】で必要な命令を調べることができますのでトライしてから"質問"してみてはどうですか?

(もこな2) 2021/11/30(火) 07:31


 おはようございます ^^
集計はピボットテーブルでお望みのものが瞬時に得られると思います。
シート訳、[ブック単位で保存?]。。。←やんないほうが解りやすいし
見やすいような気が。。。←データーバックアップ的な事でどうしても
とのことでしたら、ピボットテーブルを基に
シート訳の部分をマクロにすれば、簡単かもしれませんね。
一案です。。m(__)m
(隠居Z) 2021/11/30(火) 08:16

おはようございます。

失礼しました。
どうしても一枚一枚、いらない情報は排除して出力しなければいけないので、VBAが必要です。
重複を取り除いて、各社員ごとの売上を計算する部分のコードだけが思い浮かびません。
その他は対応できそうです。
rangeで囲って、各社員の重複箇所を計算するのだと思うのですが、この部分のコードをヒントで構いませんので教えていただきたいです。

よろしくお願いします。

(リカオン) 2021/11/30(火) 08:47


おそらく、rangeを変数に入れて、For Nextで計算するのだと思うのですが、
その後の計算コードがひねり出せないです。
(リカオン) 2021/11/30(火) 08:54

 色々方法はあるとは思いますが。一案で、 ピボットテーブル !
これ
マクロで作ってしまった方が比較的、簡単だと、私は思います
まともにぶつかると、連想配列と配列を使いまくる事となり^^;
変数も増え、かなり、煩雑なコードになるかと。。。←私の場合ですが(T_T)
その他の方法だと、
>>おそらく、rangeを変数に入れて、For Nextで計算するのだと思うのですが
↑正解だと思いますが
かなり、冗長なコードになることが想定されます。
出来なくは無いと思いますが^^;。
いま、ベテラン様がコード書いてくださっている最中かも。。。←多分ですが( ̄▽ ̄)
でわ。
(*^^*)。。。m(_ _)m
(隠居Z) 2021/11/30(火) 09:17

>隠居Zさん

計算はピボットで、シート転記にVBAという事ですね。
これなら自分でもひねり出せそうです。
少し挑戦してみます。
ありがとうございました!!
(リカオン) 2021/11/30(火) 09:20


 つくってみました ^^
いろいろ忘れかけててあほになってましたが。おさらい出来て
楽しかったです。(*^ ^*)
手抜き工事なので、ああしたら、こうしたら。。。的な事、及び
エラー処理、後始末?は考えていません。。。( ̄▽ ̄)
こんな方法でも。。。くらいに。お考えいただいて、ご考察の砌、
何かの足しにでも。←ならなければゴミ箱ポイしてくださいね。
Option Explicit
Sub OneInstanceA()
    Dim i             As Long
    Dim cx            As Long
    Dim x             As Variant
    Dim pC            As Object
    Dim pT            As Object
    Dim v()           As Variant
    Dim wSp           As Worksheet
    Dim wS1           As Worksheet
    Dim sNm           As String
    Dim r             As Range
    Dim rr            As Range
    Dim zd            As Object
    Set zd = CreateObject("Scripting.Dictionary")
    Set wS1 = Worksheets("A")
    Set r = wS1.Cells(1).CurrentRegion
    For i = 2 To r.Rows.Count
        zd(r(i, 2).Value) = r(i, 1).Value
    Next
    If Not Evaluate("=ISREF(PVT!A1)") Then Sheets.Add.Name = "PVT"
    Set wSp = Worksheets("PVT")
    wSp.Cells.Delete
    Set pC = ThisWorkbook.PivotCaches.Add(xlDatabase, wS1.Name & "!" & r.Address)
    Set pT = pC.CreatePivotTable(wSp.Name & "!r3c3", TableName:="PBXA1")
    With pT
        .PivotFields("氏名").Orientation = xlRowField
        .PivotFields("商品タイプ").Orientation = xlColumnField
        .AddDataField .PivotFields("価格"), "価格 / 合計", xlSum
    End With
    With wSp
        .PivotTables("PBXA1").TableStyle2 = "PivotStyleMedium16"
        Set rr = .PivotTables("PBXA1").TableRange1
        v = rr.Offset(1).Resize(r.Rows.Count - 1).Value
        .Cells(5, 10).Resize(UBound(v, 1), UBound(v, 2)) = v
    End With
    ThisWorkbook.ShowPivotTableFieldList = False
    For i = 2 To UBound(v, 1)
        x = zd(v(i, 1))
        sNm = v(i, 1)
        If Not Evaluate("=ISREF(" & sNm & "!A1)") Then Sheets.Add.Name = sNm
        With Worksheets(sNm)
            .UsedRange.Clear
            .Cells(1, 1) = x
            .Cells(1, 2) = v(i, 1)
            For cx = 2 To UBound(v, 2)
                .Cells(2, cx) = v(1, cx)
                .Cells(3, cx) = v(i, cx)
            Next
        End With
    Next
    zd.RemoveAll
    Erase v
End Sub
(隠居Z) 2021/11/30(火) 17:47

 商品タイプは、Sampleと他1しか想定しておりません。
 参考に
 Sub Test()
    Dim myDic As Object, d As Variant, ws As Worksheet
    Dim c As Range, v As Variant, i As Long, n As Long

    Set myDic = CreateObject("Scripting.Dictionary")
    With Worksheets("A")
        For Each c In .Range("A2", .Cells(Rows.Count, "A").End(xlUp))
            n = IIf(c.Offset(, 5).Value = "Sample", 0, 1)
            If myDic.Exists(c.Value & ":" & c.Offset(, 1).Value) Then
                v = myDic(c.Value & ":" & c.Offset(, 1))
                v(n) = v(n) + c.Offset(, 4).Value
            Else
                ReDim v(1)
                v(n) = v(n) + c.Offset(, 4).Value
            End If
        myDic(c.Value & ":" & c.Offset(, 1).Value) = v
        Next
    End With
    On Error Resume Next
    For Each d In myDic.keys
        Set ws = Worksheets(Split(d, ":")(1))
        If Err Then
            Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
            ActiveSheet.Name = Split(d, ":")(1)
            Err.Clear
        End If
        With ws
            .Range("A1").Value = 1
            .Range("B1").Value = Split(d, ":")(0)
            .Range("C1").Value = Split(d, ":")(1)
            .Range("A2").Value = 2
            .Range("B2").Value = myDic(d)(0)
            .Range("C2").Value = myDic(d)(1)
        End With
    Next
    On Error GoTo 0
    Set myDic = Nothing
 End Sub

(ピンク) 2021/11/30(火) 20:01


既に回答がありますが、投稿しておきます、

■1
>重複を取り除いて
この部分が難しいですかね。
↓が参考になるとおもいますので、一通り読むとよいと思います、
http://officetanaka.net/excel/vba/tips/tips80.htm

■2
>各社員ごとの売上を計算
普通にSUMIFS関数が使えますね。

■3
ということを踏まえると、こんなアプローチでもよいと思います。

    Sub 研究用()
        Dim 社員 As Variant
        Dim MyDic As Object
        Dim i As Long
        Dim dstWB As Workbook
        Dim dataRNG As Range

        Set MyDic = CreateObject("Scripting.Dictionary")
        With ThisWorkbook.Worksheets("シートA")

            '▼重複しない社員のリストを取得する
            On Error Resume Next
            For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
                MyDic.Add .Cells(i, "A").Value, .Cells(i, "B").Value
            Next i
            On Error GoTo 0

            '▼リストに沿って社員ごとにオートフィルタで抽出&シート(ブック)生成する
            .AutoFilterMode = False
            .Range("A1").AutoFilter
            Set dataRNG = .AutoFilter.Range

            For Each 社員 In MyDic.Keys
                Set dstWB = Workbooks.Add

                dstWB.Worksheets(1).Range("A1").Value = 社員
                dstWB.Worksheets(1).Range("B1").Value = MyDic.Item(社員)

                .AutoFilter.Range.AutoFilter Field:=1, Criteria1:=社員 & ""
                Intersect(dataRNG, dataRNG.Offset(1), .Range("F:F")).Copy dstWB.Worksheets(1).Range("A5")

                With dstWB.Worksheets(1)

                    '▼重複の削除で重複した商品タイプをユニークデータに加工する
                    .Range("A5", .Cells(.Rows.Count, "A").End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo
                    .Range("A5").CurrentRegion.Copy
                    .Range("A2").PasteSpecial Paste:=xlPasteValues, Transpose:=True
                    .Range("A5").CurrentRegion.Delete

                    '▼Sumifs関数で商品タイプごとの合計をする
                    For i = 1 To .Cells(2, .Columns.Count).End(xlToLeft).Column
                        .Cells(3, i).Value = WorksheetFunction.SumIfs(dataRNG.Columns(5), dataRNG.Columns(1), 社員, dataRNG.Columns(6), .Cells(2, i))
                    Next i

                    If MsgBox("閉じていいですか?", vbYesNo) = vbYes Then
                        dstWB.Close False
                    End If
                 End With
            Next 社員
        End With
    End Sub

■4
マルチポスト先はチェックしてないので、そちらでの議論はご自身でこのトピックに転記してください。

(もこな2) 2021/12/01(水) 07:37


みなさま

おはようございます。
本当にありがとうございます!
後ほど、サンプルを見ながら書いてみます。
取り急ぎのお礼ですm(_ _)m
(リカオン) 2021/12/02(木) 08:21


頂いたサンプルコードを元に少しアレンジしてみました。
(隠居Zさん、ぴんくさん、今のわたしには難しすぎたので、もこな2さんのサンプルで作ってみました、すみません。もっと勉強します。)

Scripting DectionaryにA,Bだけでなく、C列も記憶させてdst.Range("C5")に転記させたいのですが、どのようにすればいいか、どなたかおしえていただきたいです。調べましたが、少し複雑すぎてわかりませんでした。
コメント部分が文字化けしてしまってます。すみません。

よろしくおねがいします。

================================================

Sub Test()

Dim i As Long
Dim myDic As Object
Dim Emp As Variant
Dim dstSH As Worksheet
Dim dataRNG As Range, dateRNG2 As Range

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Set myDic = CreateObject("Scripting.Dictionary")

With ThisWorkbook.Worksheets("OriginalData")

    On Error Resume Next
    For i = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
    myDic.Add .Cells(i, "A").Value, .Cells(i, "B").Value
    Next i
    On Error GoTo 0

    .AutoFilterMode = False
    .Range("A1").AutoFilter
    Set dataRNG = .AutoFilter.Range

    For Each Emp In myDic.keys
        Set dstSH = ThisWorkbook.Worksheets("Template")

        dstSH.Range("A5").Value = Emp
        dstSH.Range("B5").Value = myDic.Item(Emp)

        .AutoFilter.Range.AutoFilter field:=1, Criteria1:=Emp & ""
        Intersect(dataRNG, dataRNG.Offset(1), .Range("C:D,F:F")).Copy
        dstSH.Range("A7").PasteSpecial Paste:=xlPasteValues

        'For ix = 7 To 13
            'If dstSH.Cells(ix, "C") = "B" Then
               'dstSH.Cells(ix, "C").Font.ColorIndex = 3
            'End If
        'Next ix

        With dstSH

           '.Range("A5", .Cells(.Rows.Count, "A").End(xlUp)).RemoveDuplicates Columns:=1, Header:=xlNo
           '.Range("A5").CurrentRegion.Copy
           '.Range("A2").PasteSpecial Paste:=xlPasteValues, Transpose:=True
           '.Range("A5").CurrentRegion.Delete

           .Range("A15").Value = WorksheetFunction.SumIfs(dataRNG.Columns(5), dataRNG.Columns(1), Emp) '?????????
           .Range("A15").Offset(, 1).Value = .Range("A15").Value * 1.1
           .Range("C15").Value = WorksheetFunction.SumIfs(dataRNG.Columns(5), dataRNG.Columns(1), Emp, dataRNG.Columns(6), "Sample") 'Sample?i?????
           .Range("C15").Offset(, 1).Value = .Range("C15").Value * 1.15 'Sample?i?????
           .Range("C15").Offset(, 2).Value = WorksheetFunction.SumIfs(dataRNG.Columns(7), dataRNG.Columns(1), Emp, dataRNG.Columns(6), "Sample") 'Sample?i?_??
           .Range("C17").Value = WorksheetFunction.SumIfs(dataRNG.Columns(5), dataRNG.Columns(1), Emp, dataRNG.Columns(6), "B") 'B?i?????
           .Range("C17").Offset(, 1).Value = .Range("C17").Value * 1.15 'B?i?????
           .Range("C17").Offset(, 2).Value = WorksheetFunction.SumIfs(dataRNG.Columns(7), dataRNG.Columns(1), Emp, dataRNG.Columns(6), "B") 'B?i?_??
           .Range("C20") = .Range("E15").Value + .Range("E15").Offset(2).Value '???v?_??
        End With

        With ThisWorkbook.Worksheets("Template")
            .Copy '?uTEST1?v?V?[?g??V?????u?b?N??R?s?[
            ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Emp & myDic.Item(Emp), FileFormat:=1 '?V???????????u?b?N???O??t??????
            ActiveWorkbook.Close False '?V???????????u?b?N??????
            .Range("A5").Resize(1, 3).ClearContents
            .Range("A7").Resize(7, 4).ClearContents
            .Range("A15").Resize(1, 5).ClearContents
            .Range("A17").Resize(1, 5).ClearContents
            .Range("A20").Resize(1, 3).ClearContents
        End With

         'If MsgBox("??????????????H", vbYesNo) = vbYes Then
             'dstWB.Close False
         'End If
         '.AutoFilterMode = False
    Next Emp
End With

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

(リカオン) 2021/12/21(火) 21:20


随分と前のことなので当時どのように考えたか忘れてしまいましたが、どこでどう詰まってるのですか?
(コード中に示されているのかもしれませんが、文字化けしてしまっているので詳細まで見る気が起きず、提示のコードはよく読んでません。)

もしも、重複しないリストの作成で困っているのであれば「■1」で示したように連想配列を使うのが唯一の手というわけではありませんから、理解できないのであれば別のアプローチにしてはどうですか?

また、「■4」でコメントしたように、マルチポストしたならちゃんとご自身で始末をつけるべきでしょう。

(もこな2 ) 2021/12/21(火) 23:07


追加で。読める範囲で読んでみた感想です。

★1
なんで↓をループで繰り返すのですか?

 Set dstSH = ThisWorkbook.Worksheets("Template")

★2
↓決め打ちなら、offsetしなくてよいのでは?

 .Range("A15").Offset(, 1).Value
 .Range("C15").Offset(, 1).Value
 .Range("C15").Offset(, 2).Value
 .Range("C17").Offset(, 1).Value
 .Range("C17").Offset(, 2).Value

★3
↓決め打ちならResizeしなくてもよいのでは?

 .Range("A5").Resize(1, 3).ClearContents
 .Range("A7").Resize(7, 4).ClearContents
 .Range("A15").Resize(1, 5).ClearContents
 .Range("A17").Resize(1, 5).ClearContents
 .Range("A20").Resize(1, 3).ClearContents

★4
「★1」「★3」に関連して、いちいちClearContentsするくらいなら、ThisWorkbook.Worksheets("Template")を新規ブックにコピーしてそちらに出力すればよいのでは?

(もこな2) 2021/12/22(水) 09:02


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.