teratail
回答率
85.35%
teratail header banner
teratail header banner
質問するログイン新規登録
トップに関する質問EXCEL VBAでサイン付きパック項目を含むデータを出力したい

編集履歴

質問編集履歴

4

現状を修正

2020/03/09 05:37

投稿

kawanishi_JUKE
kawanishi_JUKE

スコア5

test CHANGED
File without changes
test CHANGED
@@ -24,6 +24,14 @@
24
24
 
25
25
 
26
26
 
27
+ 'COMP-3項目を書き出す
28
+
29
+ の部分でサインなしであれば変換できています（00 00 00 01 00 00）
30
+
31
+ ただbyte形式で変換しているためcを入れることができない状況です。
32
+
33
+
34
+
27
35
 
28
36
 
29
37
  ### 該当のソースコード

3

2020/03/09 05:37

投稿

kawanishi_JUKE
kawanishi_JUKE

スコア5

test CHANGED
File without changes
test CHANGED
@@ -14,6 +14,18 @@
14
14
 
15
15
 
16
16
 
17
+ ### 現状
18
+
19
+ 1.バイナリでパック項目前までバイト形式にして書き出し
20
+
21
+ 2.パック項目を変換書き出し(seekで追記)
22
+
23
+ 3.パックが出てくるまで1を繰り返す
24
+
25
+
26
+
27
+
28
+
17
29
  ### 該当のソースコード
18
30
 
19
31
 
@@ -66,10 +78,6 @@
66
78
 
67
79
  FileNumber = FreeFile
68
80
 
69
- ' 'ファイルをAppendモードで開きます。
70
-
71
- ' Open strPath For Binary As #FileNumber
72
-
73
81
  With ActiveWorkbook.Worksheets("データ作成")
74
82
 
75
83
 
@@ -144,7 +152,7 @@
144
152
 
145
153
  bbuf = StrConv(s, vbFromUnicode)
146
154
 
147
- 'ファイルをAppendモードで開きます。
155
+
148
156
 
149
157
  Open strPath For Binary As #FileNumber
150
158
 
@@ -178,7 +186,7 @@
178
186
 
179
187
 
180
188
 
181
- 'ファイルをAppendモードで開きます。
189
+
182
190
 
183
191
  Open strPath For Binary As #FileNumber
184
192
 
@@ -222,7 +230,7 @@
222
230
 
223
231
 
224
232
 
225
- 'パック項目が来たら一旦書き出す
233
+
226
234
 
227
235
  Erase bbuf
228
236
 
@@ -242,21 +250,9 @@
242
250
 
243
251
  Close #FileNumber
244
252
 
245
-
246
-
247
-
248
-
249
-
250
-
251
253
  End With
252
254
 
253
-
254
-
255
-
256
-
257
- ' 'データ書き出し
255
+
258
-
259
- ' Put #FileNumber, 1, bbuf
260
256
 
261
257
  '入力ファイルを閉じます。
262
258
 

2

ソース修正

2020/03/09 04:59

投稿

kawanishi_JUKE
kawanishi_JUKE

スコア5

test CHANGED
File without changes
test CHANGED
@@ -16,13 +16,15 @@
16
16
 
17
17
  ### 該当のソースコード
18
18
 
19
- Sub データ出力()
19
+
20
-
21
-
22
-
20
+
21
+
22
+
23
- 'データ格納用
23
+ 　　'データ格納用
24
+
24
-
25
+ ```Sub データ出力()
26
+
25
- Dim bbuf() As Byte
27
+ 　　　Dim bbuf() As Byte
26
28
 
27
29
  Dim s As String
28
30
 
@@ -258,4 +260,6 @@
258
260
 
259
261
  '入力ファイルを閉じます。
260
262
 
261
- Close #FileNumber
263
+ Close #FileNumber
264
+
265
+ ```

1

ソース追加

2020/03/09 04:45

投稿

kawanishi_JUKE
kawanishi_JUKE

スコア5

test CHANGED
File without changes
test CHANGED
@@ -16,4 +16,246 @@
16
16
 
17
17
  ### 該当のソースコード
18
18
 
19
+ Sub データ出力()
20
+
21
+
22
+
23
+ 'データ格納用
24
+
19
- dim bbuf() as byte
25
+ Dim bbuf() As Byte
26
+
27
+ Dim s As String
28
+
29
+ Dim bData() As Byte
30
+
31
+ Dim cData() As Byte
32
+
33
+
34
+
35
+ 'ファイル作成
36
+
37
+ Dim objFso As Object
38
+
39
+ Set objFso = CreateObject("Scripting.FileSystemObject")
40
+
41
+
42
+
43
+ Dim strPath As String
44
+
45
+ strPath = ActiveWorkbook.Worksheets("データ作成").Range("C1").Value
46
+
47
+
48
+
49
+ With objFso
50
+
51
+ If Not .FileExists(strPath) Then
52
+
53
+ .CreateTextFile (strPath)
54
+
55
+ End If
56
+
57
+ End With
58
+
59
+ Set objFso = Nothing
60
+
61
+
62
+
63
+ '空いているファイル番号を取得します。
64
+
65
+ FileNumber = FreeFile
66
+
67
+ ' 'ファイルをAppendモードで開きます。
68
+
69
+ ' Open strPath For Binary As #FileNumber
70
+
71
+ With ActiveWorkbook.Worksheets("データ作成")
72
+
73
+
74
+
75
+ 'データをコピーする
76
+
77
+ copyCol = 24
78
+
79
+ Do While .Cells(copyCol, 2) <> ""
80
+
81
+ Select Case .Cells(copyCol, 2)
82
+
83
+ 'ヘッダ時の処理
84
+
85
+ Case "ヘッダ"
86
+
87
+ itemsu = 134
88
+
89
+ dataGata = 8
90
+
91
+ '商品時の処理
92
+
93
+ Case "エンド"
94
+
95
+ itemsu = 2
96
+
97
+ dataGata = 23
98
+
99
+ '対象レコード以外の処理
100
+
101
+ Case Else
102
+
103
+ MsgBox "レコード区分に誤りがあります！！"
104
+
105
+ Exit Do
106
+
107
+ End Select
108
+
109
+
110
+
111
+ 'アイテム数分ループする
112
+
113
+ For i = 0 To itemsu - 1
114
+
115
+
116
+
117
+ If .Cells(copyCol, 2) = "ヘッダ" And i = 0 Then
118
+
119
+ s = s & "10 "
120
+
121
+ i = 1
122
+
123
+ Else
124
+
125
+ If .Cells(copyCol, 2) = "エンド" And i = 0 Then
126
+
127
+ s = s & "99 "
128
+
129
+ i = 1
130
+
131
+ Else
132
+
133
+
134
+
135
+ If .Cells(dataGata, 3 + i) = "COMP-3" Then
136
+
137
+
138
+
139
+ 'パック項目が来たら一旦書き出す
140
+
141
+ Erase bbuf
142
+
143
+ bbuf = StrConv(s, vbFromUnicode)
144
+
145
+ 'ファイルをAppendモードで開きます。
146
+
147
+ Open strPath For Binary As #FileNumber
148
+
149
+
150
+
151
+ 'データ書き出し
152
+
153
+ Seek #FileNumber, FileLen(strPath) + 1
154
+
155
+ Put #FileNumber, , bbuf
156
+
157
+ '入力ファイルを閉じます。
158
+
159
+ Close #FileNumber
160
+
161
+ s = ""
162
+
163
+
164
+
165
+ 'COMP-3項目を書き出す
166
+
167
+ ReDim cData(0 To Len(.Cells(copyCol, 3 + i).Value) / 2 - 1)
168
+
169
+ s = Mid(Cells(copyCol, 3 + i).Value, 2, Len(Cells(copyCol, 3 + i).Value) - 1)
170
+
171
+ For j = 1 To Len(.Cells(copyCol, 3 + i).Value) Step 2
172
+
173
+ cData((j - 1) / 2) = CByte("&H" & Mid(s, j, 2))
174
+
175
+ Next
176
+
177
+
178
+
179
+ 'ファイルをAppendモードで開きます。
180
+
181
+ Open strPath For Binary As #FileNumber
182
+
183
+
184
+
185
+ 'データ書き出し
186
+
187
+ Seek #FileNumber, FileLen(strPath) + 1
188
+
189
+ Put #FileNumber, , cData
190
+
191
+ '入力ファイルを閉じます。
192
+
193
+ Close #FileNumber
194
+
195
+ s = ""
196
+
197
+
198
+
199
+ Else
200
+
201
+ '通常項目
202
+
203
+ s = s & .Cells(copyCol, 3 + i).Value
204
+
205
+ End If
206
+
207
+ End If
208
+
209
+ End If
210
+
211
+
212
+
213
+ Next
214
+
215
+ '次レコードへ
216
+
217
+ copyCol = copyCol + 1
218
+
219
+ Loop
220
+
221
+
222
+
223
+ 'パック項目が来たら一旦書き出す
224
+
225
+ Erase bbuf
226
+
227
+ bbuf = StrConv(s, vbFromUnicode)
228
+
229
+ 'ファイルをAppendモードで開きます。
230
+
231
+ Open strPath For Binary As #FileNumber
232
+
233
+ 'データ書き出し
234
+
235
+ Seek #FileNumber, FileLen(strPath) + 1
236
+
237
+ Put #FileNumber, , bbuf
238
+
239
+ '入力ファイルを閉じます。
240
+
241
+ Close #FileNumber
242
+
243
+
244
+
245
+
246
+
247
+
248
+
249
+ End With
250
+
251
+
252
+
253
+
254
+
255
+ ' 'データ書き出し
256
+
257
+ ' Put #FileNumber, 1, bbuf
258
+
259
+ '入力ファイルを閉じます。
260
+
261
+ Close #FileNumber