[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『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)のブックの１番目のシートに出力（書き込みやコピペ）する (3)(2)ブックを名前を付けて保存する (4)(3)のブックを閉じる
という処理を繰り返せばよいのではありませんか？
繰り返し処理はともかく、そのほかは【マクロの記録】で必要な命令を調べることができますのでトライしてから"質問"してみてはどうですか？
（もこな２） 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
■１
＞重複を取り除いて
この部分が難しいですかね。
↓が参考になるとおもいますので、一通り読むとよいと思います、
http://officetanaka.net/excel/vba/tips/tips80.htm
■２
＞各社員ごとの売上を計算
普通にSUMIFS関数が使えますね。
■３
ということを踏まえると、こんなアプローチでもよいと思います。
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
■４
マルチポスト先はチェックしてないので、そちらでの議論はご自身でこのトピックに転記してください。
（もこな２） 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
もしも、重複しないリストの作成で困っているのであれば「■１」で示したように連想配列を使うのが唯一の手というわけではありませんから、理解できないのであれば別のアプローチにしてはどうですか？
また、「■４」でコメントしたように、マルチポストしたならちゃんとご自身で始末をつけるべきでしょう。
（もこな２ ） 2021/12/21(火) 23:07
★１
なんで↓をループで繰り返すのですか？
Set dstSH = ThisWorkbook.Worksheets("Template")
★２
↓決め打ちなら、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
★３
↓決め打ちなら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
★４
「★１」「★３」に関連して、いちいちClearContentsするくらいなら、ThisWorkbook.Worksheets("Template")を新規ブックにコピーしてそちらに出力すればよいのでは？
（もこな２） 2021/12/22(水) 09:02
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.