teratail
回答率
85.35%
teratail header banner
teratail header banner
質問するログイン新規登録
トップVBAに関する質問売上管理シートの作成

編集履歴

回答編集履歴

4

追記

2021/11/30 06:59

投稿

jinoji
jinoji

スコア4592

test CHANGED
@@ -101,3 +101,135 @@
101
101
 
102
102
 
103
103
  ```
104
+
105
+
106
+
107
+ ---
108
+
109
+ ＜追記＞　整理整頓。
110
+
111
+
112
+
113
+ ```VBA
114
+
115
+ Sub total()
116
+
117
+
118
+
119
+ 'シートの準備
120
+
121
+ With ThisWorkbook
122
+
123
+ Dim meisai As Worksheet
124
+
125
+ Dim urikan As Worksheet
126
+
127
+ Set meisai = .Worksheets("明細")
128
+
129
+ Set urikan = .Worksheets("売上管理")
130
+
131
+ End With
132
+
133
+
134
+
135
+ '明細を取得し集計
136
+
137
+ With meisai
138
+
139
+ '連想配列（重複除去用）の準備
140
+
141
+ Dim myDic As Object
142
+
143
+ Set myDic = CreateObject("Scripting.Dictionary")
144
+
145
+
146
+
147
+ '明細データの格納
148
+
149
+ Dim ProductCode, ProductName, Tanka, Hanbaisuu, Hanbaigaku
150
+
151
+ Dim varKodoNamePrice As Variant
152
+
153
+ Dim i
154
+
155
+ For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
156
+
157
+ ProductCode = .Cells(i, 1).Value
158
+
159
+ If Not myDic.Exists(ProductCode) Then
160
+
161
+ ProductName = .Cells(i, 2).Value
162
+
163
+ Tanka = .Cells(i, 3).Value
164
+
165
+ Hanbaisuu = WorksheetFunction.CountIf(.Columns(1), ProductCode)
166
+
167
+ Hanbaigaku = Tanka * Hanbaisuu
168
+
169
+ varKodoNamePrice = Array(ProductCode, ProductName, Tanka, Hanbaisuu, Hanbaigaku)
170
+
171
+ myDic.Add ProductCode, varKodoNamePrice
172
+
173
+ End If
174
+
175
+ Next i
176
+
177
+
178
+
179
+ '出力用配列の準備
180
+
181
+ Dim myItems As Variant, myCount As Long
182
+
183
+ myItems = WorksheetFunction.Transpose(WorksheetFunction.Transpose(myDic.Items))
184
+
185
+ myCount = myDic.Count
186
+
187
+ End With
188
+
189
+
190
+
191
+
192
+
193
+ '売上管理に出力
194
+
195
+ With urikan
196
+
197
+ '開始行の決定
198
+
199
+ Dim lngNewRow As Long
200
+
201
+ lngNewRow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Row
202
+
203
+
204
+
205
+ '連番、日付の決定
206
+
207
+ Dim lngNo As Long, strNow As String
208
+
209
+ lngNo = WorksheetFunction.Max(.Columns(1)) + 1
210
+
211
+ strNow = Format(Now, "YYYY/MM/DD hh:mm")
212
+
213
+
214
+
215
+ '連番、日付の出力、セル結合
216
+
217
+ .Cells(lngNewRow, 1).Resize(, 2).Value = Array(lngNo, strNow)
218
+
219
+ .Cells(lngNewRow, 1).Resize(myCount).Merge
220
+
221
+ .Cells(lngNewRow, 2).Resize(myCount).Merge
222
+
223
+
224
+
225
+ '明細の出力
226
+
227
+ .Cells(lngNewRow, 3).Resize(myCount, 5).Value = myItems
228
+
229
+ End With
230
+
231
+
232
+
233
+ End Sub
234
+
235
+ ```

3

修正

2021/11/30 06:59

投稿

jinoji
jinoji

スコア4592

test CHANGED
@@ -1,42 +1,40 @@
1
- 日時や金額の書式は最初にシートのセル書式を設定しておけばよいと思うので、
2
-
3
- Noとセル結合のところを書いておきます。
1
+ 修正して再掲。
4
2
 
5
3
 
6
4
 
7
5
  ```VBA
8
6
 
9
- With Worksheets("売上管理")
7
+ Sub total()
10
8
 
11
- '
9
+ '売上管理のシートにNo、販売日時、商品コード、商品名、単価、販売数、販売額を記入
12
10
 
13
- '
11
+ Dim k
14
12
 
15
- lngNo = WorksheetFunction.Max(.Columns(1)) + 1
13
+ Dim lngNo As Long
16
14
 
17
- .Cells(lngEndRow, 1).Offset(1).Value = lngNo
15
+ Dim strNitiji As String
18
16
 
19
- .Cells(lngEndRow, 1).Offset(1).Resize(myDic.Count).Merge
17
+ Dim varKodoNamePrice As Variant
20
18
 
21
- .Cells(lngEndRow, 2).Offset(1).Resize(myDic.Count).Merge
19
+ strNitiji = Format(Now, "YYYY/MM/DD hh:mm")
22
20
 
23
- End With
21
+ Dim lngEndRow: lngEndRow = Worksheets("売上管理").Cells(Rows.Count, 1).End(xlUp).Row
24
22
 
25
- ```
23
+ Dim Arow As Long
24
+
25
+ Dim i As Long, j As Long
26
+
27
+ Dim myDic As Object
28
+
29
+ Dim mykeys, myItems
30
+
31
+ Dim varArrayItems As Variant
32
+
33
+ Dim ProductCode, ProductName, Tanka, Hanbaisuu, Hanbaigaku
34
+
35
+ Set myDic = CreateObject("Scripting.Dictionary")
26
36
 
27
37
 
28
-
29
- （元のコードにも気になることはありますが一旦見ないふり・・・）
30
-
31
-
32
-
33
- ---
34
-
35
- ＜追記＞
36
-
37
-
38
-
39
- ```VBA
40
38
 
41
39
  'A列でリストの最終行を調べる
42
40
 
@@ -46,27 +44,25 @@
46
44
 
47
45
  With Worksheets("明細")
48
46
 
49
- Dim c, n, t, s, g, arr
50
-
51
47
  For i = 2 To Arow
52
48
 
53
- c = .Cells(i, 1).Value
49
+ ProductCode = .Cells(i, 1).Value
54
50
 
55
- If Not myDic.Exists(c) Then
51
+ If Not myDic.Exists(ProductCode) Then
56
52
 
57
- n = .Cells(i, 2).Value
53
+ ProductName = .Cells(i, 2).Value
58
54
 
59
- t = .Cells(i, 3).Value
55
+ Tanka = .Cells(i, 3).Value
60
56
 
61
- s = WorksheetFunction.CountIf(.Columns(1), c)
57
+ Hanbaisuu = WorksheetFunction.CountIf(.Columns(1), ProductCode)
62
58
 
63
- g = t * s
59
+ Hanbaigaku = Tanka * Hanbaisuu
64
60
 
65
- arr = Array(c, n, t, s, g)
61
+ varKodoNamePrice = Array(ProductCode, ProductName, Tanka, Hanbaisuu, Hanbaigaku)
66
62
 
67
63
  '連想配列、キーとデータを追加する
68
64
 
69
- myDic.Add c, arr
65
+ myDic.Add ProductCode, varKodoNamePrice
70
66
 
71
67
  End If
72
68
 
@@ -74,17 +70,9 @@
74
70
 
75
71
  End With
76
72
 
77
-
73
+
78
74
 
79
75
  With Worksheets("売上管理")
80
-
81
- lngNo = WorksheetFunction.Max(.Columns(1)) + 1
82
-
83
- .Cells(lngEndRow, 1).Offset(1).Value = lngNo
84
-
85
- .Cells(lngEndRow, 1).Offset(1).Resize(myDic.Count).Merge
86
-
87
- .Cells(lngEndRow, 2).Offset(1).Resize(myDic.Count).Merge
88
76
 
89
77
  myItems = myDic.Items
90
78
 
@@ -92,11 +80,23 @@
92
80
 
93
81
  'キーとデータをセルに表示する
94
82
 
95
- .Range("C" & j + 2).Resize(, 5).Value = myItems(j)
83
+ .Cells(lngEndRow, 1).Offset(1 + j, 2).Resize(, 5).Value = myItems(j)
96
84
 
97
85
  Next j
98
86
 
87
+
88
+
89
+ lngNo = WorksheetFunction.Max(.Columns(1)) + 1
90
+
91
+ .Cells(lngEndRow, 1).Offset(1).Resize(, 2).Value = Array(lngNo, strNitiji)
92
+
93
+ .Cells(lngEndRow, 1).Offset(1).Resize(myDic.Count).Merge
94
+
95
+ .Cells(lngEndRow, 2).Offset(1).Resize(myDic.Count).Merge
96
+
99
97
  End With
98
+
99
+ End Sub
100
100
 
101
101
 
102
102
 

2

追記

2021/11/30 02:28

投稿

jinoji
jinoji

スコア4592

test CHANGED
@@ -27,3 +27,77 @@
27
27
 
28
28
 
29
29
  （元のコードにも気になることはありますが一旦見ないふり・・・）
30
+
31
+
32
+
33
+ ---
34
+
35
+ ＜追記＞
36
+
37
+
38
+
39
+ ```VBA
40
+
41
+ 'A列でリストの最終行を調べる
42
+
43
+ Arow = Worksheets("明細").Cells(Rows.Count, 1).End(xlUp).Row
44
+
45
+
46
+
47
+ With Worksheets("明細")
48
+
49
+ Dim c, n, t, s, g, arr
50
+
51
+ For i = 2 To Arow
52
+
53
+ c = .Cells(i, 1).Value
54
+
55
+ If Not myDic.Exists(c) Then
56
+
57
+ n = .Cells(i, 2).Value
58
+
59
+ t = .Cells(i, 3).Value
60
+
61
+ s = WorksheetFunction.CountIf(.Columns(1), c)
62
+
63
+ g = t * s
64
+
65
+ arr = Array(c, n, t, s, g)
66
+
67
+ '連想配列、キーとデータを追加する
68
+
69
+ myDic.Add c, arr
70
+
71
+ End If
72
+
73
+ Next i
74
+
75
+ End With
76
+
77
+
78
+
79
+ With Worksheets("売上管理")
80
+
81
+ lngNo = WorksheetFunction.Max(.Columns(1)) + 1
82
+
83
+ .Cells(lngEndRow, 1).Offset(1).Value = lngNo
84
+
85
+ .Cells(lngEndRow, 1).Offset(1).Resize(myDic.Count).Merge
86
+
87
+ .Cells(lngEndRow, 2).Offset(1).Resize(myDic.Count).Merge
88
+
89
+ myItems = myDic.Items
90
+
91
+ For j = 0 To myDic.Count - 1
92
+
93
+ 'キーとデータをセルに表示する
94
+
95
+ .Range("C" & j + 2).Resize(, 5).Value = myItems(j)
96
+
97
+ Next j
98
+
99
+ End With
100
+
101
+
102
+
103
+ ```

1

修正

2021/11/26 06:17

投稿

jinoji
jinoji

スコア4592

test CHANGED
@@ -16,9 +16,9 @@
16
16
 
17
17
  .Cells(lngEndRow, 1).Offset(1).Value = lngNo
18
18
 
19
- .Cells(lngEndRow, 1).Offset(1).Resize(Arow - 1).Merge
19
+ .Cells(lngEndRow, 1).Offset(1).Resize(myDic.Count).Merge
20
20
 
21
- .Cells(lngEndRow, 2).Offset(1).Resize(Arow - 1).Merge
21
+ .Cells(lngEndRow, 2).Offset(1).Resize(myDic.Count).Merge
22
22
 
23
23
  End With
24
24