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