VBA 農産物売上集計 – テックメモ

mdbに登録する予定で作成していたが、途中でエクセルのみにしようと思い中断。

Sub auto_open()

On Error Resume Next

Application.CommandBars("cell").Controls("処理実行").Delete
Application.CommandBars("cell").Controls("シート初期化(貼付前処理)").Delete

With Application.CommandBars("cell").Controls.Add
.FaceId = 18
.Caption = "シート初期化(貼付前処理)"
.OnAction = "SheetsClear"
End With

With Application.CommandBars("cell").Controls.Add
.FaceId = 18
.Caption = "処理実行"
.OnAction = "MainProcedure"
End With

End Sub

Sub auto_close()

On Error Resume Next

Application.CommandBars("cell").Controls("処理実行").Delete
Application.CommandBars("cell").Controls("シート初期化(貼付前処理)").Delete

End Sub

Sub SheetsClear()

Sheets("<実績表集計表>貼付1").Rows("1:1000").Delete
Sheets("<実績表集計表>貼付2").Rows("1:1000").Delete
Sheets("<買取業者別 手数料集計一覧表>貼付").Rows("1:1000").Delete

End Sub

Sub MainProcedure()

On Error GoTo e

YearMonth = InputBox("登録月をYYYY/MMの形式で入力してください。")
YearMonth = StrConv(YearMonth, vbNarrow)
YearMonth = YearMonth & "/01"

If True = IsDate(YearMonth) Then

  yesno = MsgBox(Format(YearMonth, "yyyy年mm月") & "でよろしいですか？", vbYesNo)
  If yesno = vbNo Then Exit Sub

Else

  MsgBox "正しい登録月を入力してください。"
  Exit Sub

End If

If False = DataUpload("<実績表集計表>貼付1", 1, YearMonth) Then GoTo e
If False = DataUpload("<実績表集計表>貼付2", 1, YearMonth) Then GoTo e
If False = DataUpload("<買取業者別 手数料集計一覧表>貼付", 2, YearMonth) Then GoTo e

MsgBox "完了しました。"

Exit Sub

e:
  
  MsgBox "エラーが発生しています。"

End Sub

Function DataUpload(sheetName, sheetType, salesDate)

On Error GoTo e

Set con = CreateObject("adodb.connection")
con.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.Path & "/sales.mdb")

Dim w As Worksheet: Set w = Sheets(sheetName)


For r = 1 To w.UsedRange.Rows.Count

  If sheetType = 1 And _
  w.Cells(r, 1).Text <> "" And IsNumeric(w.Cells(r, 1).Text) And _
  w.Cells(r, 8).Text <> "" And IsNumeric(w.Cells(r, 8).Text) Then
  
    partnerCode = w.Cells(r, 1).Text
    partnerName = w.Cells(r, 2).Text
    salesVolume = w.Cells(r, 6).Text
    salesAmount = w.Cells(r, 7).Text
    marginCost = w.Cells(r, 10).Text
    pointCost = w.Cells(r, 18).Text
    overheadCost = w.Cells(r, 19).Text
    
    q = "insert into SalesTable (売上年月日,パートナーID,パートナー名称,売上数量,売上金額,手数料,ポイント負担額,諸経費,登録日時) " & _
    "values (#" & salesDate & "#,'" & partnerCode & "','" & partnerName & "','" & salesVolume & "','" & salesAmount & "','" & marginCost & "','" & pointCost & "','" & overheadCost & "',#" & Now() & "#)"
    
    con.Execute q
  
  End If
  
  If sheetType = 2 And _
  w.Cells(r, 1).Text <> "" And IsNumeric(w.Cells(r, 1).Text) And _
  w.Cells(r, 4).Text <> "" And IsNumeric(w.Cells(r, 4).Text) Then
  
    partnerCode = w.Cells(r, 1).Text
    partnerName = w.Cells(r, 2).Text
    salesVolume = w.Cells(r, 4).Text
    salesAmount = w.Cells(r, 5).Text
    marginCost = w.Cells(r, 7).Text
    pointCost = w.Cells(r, 9).Text
    overheadCost = 0

    q = "insert into SalesTable (売上年月日,パートナーID,パートナー名称,売上数量,売上金額,手数料,ポイント負担額,諸経費,登録日時) " & _
    "values (#" & salesDate & "#,'" & partnerCode & "','" & partnerName & "','" & salesVolume & "','" & salesAmount & "','" & marginCost & "','" & pointCost & "','" & overheadCost & "',#" & Now() & "#)"
    
    con.Execute q
    
  End If

Next r

If con.State = 1 Then con.Close
Set con = Nothing

DataUpload = True

Exit Function

e:

  If con.State = 1 Then con.Close
  Set con = Nothing
  
  DataUpload = False
  
End Function

Sub MasterUpdate()

On Error GoTo e

Set con = CreateObject("adodb.connection")
con.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.Path & "/sales.mdb")

q = "delete from MasterTable"
con.Execute q

Dim w As Worksheet: Set w = Sheets("マスタ")
        
For r = 1 To w.UsedRange.Rows.Count

  If w.Cells(r, 1).Text <> "" And w.Cells(r, 2).Text <> "" And w.Cells(r, 3).Text <> "" Then
  
    Select Case w.Cells(r, 3).Text
    
      Case "正契約農産物", "準契約農産物", "委託農産物", "買取農産物", "花卉", "契約加工品", "委託加工品", "買取加工品"
      
        partnerCode = w.Cells(r, 1).Text
        partnerName = w.Cells(r, 2).Text
        partnerType = w.Cells(r, 3).Text
    
        q = "insert into MasterTable (パートナーID,パートナー名称,パートナータイプ,登録日時) " & _
        "values ('" & partnerCode & "','" & partnerName & "','" & partnerType & "',#" & Now() & "#)"
        
        con.Execute q
        
        w.Rows(r).Columns("A:C").Interior.ColorIndex = 0 ' OKの場合
    
      Case Else
      
        w.Cells(r, 3).Interior.Color = RGB(255, 0, 0) 'A:Cは空白ではないが、C列が不正

    End Select
    
  Else
  
    w.Rows(r).Columns("A:C").Interior.Color = RGB(255, 0, 0) 'A:C列の何れか空白
  
  End If

Next r

If con.State = 1 Then con.Close
Set con = Nothing

MsgBox "完了しました。"

Exit Sub

e:

  If con.State = 1 Then con.Close
  Set con = Nothing
  
  MsgBox "エラーが発生しています。"
  
End Sub

Sub DataDelte()

On Error GoTo e

Dim w As Worksheet: Set w = Sheets("表紙")

yesno = MsgBox(w.Cells(6, 2).Text & "の日付で登録したデータは全て削除されます。よろしいですか？", vbYesNo)
If yesno = vbNo Then Exit Sub

Set con = CreateObject("adodb.connection")
con.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.Path & "/sales.mdb")

q = "delete from SalesTable where 売上年月日 = #" & w.Cells(6, 2).Text & "#"
con.Execute q

If con.State = 1 Then con.Close
Set con = Nothing

MsgBox "完了しました。"

Exit Sub

e:

  If con.State = 1 Then con.Close
  Set con = Nothing
  
  MsgBox "エラーが発生しています。"
  
End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

Sub auto_open()

On Error Resume Next

Application.CommandBars("cell").Controls("処理実行").Delete

Application.CommandBars("cell").Controls("シート初期化(貼付前処理)").Delete

With Application.CommandBars("cell").Controls.Add

.FaceId = 18

.Caption = "シート初期化(貼付前処理)"

.OnAction = "SheetsClear"

End With

With Application.CommandBars("cell").Controls.Add

.FaceId = 18

.Caption = "処理実行"

.OnAction = "MainProcedure"

End With

End Sub

Sub auto_close()

On Error Resume Next

Application.CommandBars("cell").Controls("処理実行").Delete

Application.CommandBars("cell").Controls("シート初期化(貼付前処理)").Delete

End Sub

Sub SheetsClear()

Sheets("<実績表集計表>貼付1").Rows("1:1000").Delete

Sheets("<実績表集計表>貼付2").Rows("1:1000").Delete

Sheets("<買取業者別手数料集計一覧表>貼付").Rows("1:1000").Delete

End Sub

Sub MainProcedure()

On Error GoTo e

YearMonth = InputBox("登録月をYYYY/MMの形式で入力してください。")

YearMonth = StrConv(YearMonth, vbNarrow)

YearMonth = YearMonth & "/01"

If True = IsDate(YearMonth) Then

yesno = MsgBox(Format(YearMonth, "yyyy年mm月") & "でよろしいですか？", vbYesNo)

If yesno = vbNo Then Exit Sub

Else

MsgBox "正しい登録月を入力してください。"

Exit Sub

End If

If False = DataUpload("<実績表集計表>貼付1", 1, YearMonth) Then GoTo e

If False = DataUpload("<実績表集計表>貼付2", 1, YearMonth) Then GoTo e

If False = DataUpload("<買取業者別手数料集計一覧表>貼付", 2, YearMonth) Then GoTo e

MsgBox "完了しました。"

Exit Sub

MsgBox "エラーが発生しています。"

End Sub

Function DataUpload(sheetName, sheetType, salesDate)

On Error GoTo e

Set con = CreateObject("adodb.connection")

con.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.Path & "/sales.mdb")

Dim w As Worksheet: Set w = Sheets(sheetName)

For r = 1 To w.UsedRange.Rows.Count

If sheetType = 1 And _

w.Cells(r, 1).Text <> "" And IsNumeric(w.Cells(r, 1).Text) And _

w.Cells(r, 8).Text <> "" And IsNumeric(w.Cells(r, 8).Text) Then

partnerCode = w.Cells(r, 1).Text

partnerName = w.Cells(r, 2).Text

salesVolume = w.Cells(r, 6).Text

salesAmount = w.Cells(r, 7).Text

marginCost = w.Cells(r, 10).Text

pointCost = w.Cells(r, 18).Text

overheadCost = w.Cells(r, 19).Text

q = "insert into SalesTable (売上年月日,パートナーID,パートナー名称,売上数量,売上金額,手数料,ポイント負担額,諸経費,登録日時) " & _

"values (#" & salesDate & "#,'" & partnerCode & "','" & partnerName & "','" & salesVolume & "','" & salesAmount & "','" & marginCost & "','" & pointCost & "','" & overheadCost & "',#" & Now() & "#)"

con.Execute q

End If

If sheetType = 2 And _

w.Cells(r, 1).Text <> "" And IsNumeric(w.Cells(r, 1).Text) And _

w.Cells(r, 4).Text <> "" And IsNumeric(w.Cells(r, 4).Text) Then

partnerCode = w.Cells(r, 1).Text

partnerName = w.Cells(r, 2).Text

salesVolume = w.Cells(r, 4).Text

salesAmount = w.Cells(r, 5).Text

marginCost = w.Cells(r, 7).Text

pointCost = w.Cells(r, 9).Text

overheadCost = 0

q = "insert into SalesTable (売上年月日,パートナーID,パートナー名称,売上数量,売上金額,手数料,ポイント負担額,諸経費,登録日時) " & _

"values (#" & salesDate & "#,'" & partnerCode & "','" & partnerName & "','" & salesVolume & "','" & salesAmount & "','" & marginCost & "','" & pointCost & "','" & overheadCost & "',#" & Now() & "#)"

con.Execute q

End If

Next r

If con.State = 1 Then con.Close

Set con = Nothing

DataUpload = True

Exit Function

If con.State = 1 Then con.Close

Set con = Nothing

DataUpload = False

End Function

Sub MasterUpdate()

On Error GoTo e

Set con = CreateObject("adodb.connection")

con.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.Path & "/sales.mdb")

q = "delete from MasterTable"

con.Execute q

Dim w As Worksheet: Set w = Sheets("マスタ")

For r = 1 To w.UsedRange.Rows.Count

If w.Cells(r, 1).Text <> "" And w.Cells(r, 2).Text <> "" And w.Cells(r, 3).Text <> "" Then

Select Case w.Cells(r, 3).Text

Case "正契約農産物", "準契約農産物", "委託農産物", "買取農産物", "花卉", "契約加工品", "委託加工品", "買取加工品"

partnerCode = w.Cells(r, 1).Text

partnerName = w.Cells(r, 2).Text

partnerType = w.Cells(r, 3).Text

q = "insert into MasterTable (パートナーID,パートナー名称,パートナータイプ,登録日時) " & _

"values ('" & partnerCode & "','" & partnerName & "','" & partnerType & "',#" & Now() & "#)"

con.Execute q

w.Rows(r).Columns("A:C").Interior.ColorIndex = 0 ' OKの場合

Case Else

w.Cells(r, 3).Interior.Color = RGB(255, 0, 0) 'A:Cは空白ではないが、C列が不正

End Select

Else

w.Rows(r).Columns("A:C").Interior.Color = RGB(255, 0, 0) 'A:C列の何れか空白

End If

Next r

If con.State = 1 Then con.Close

Set con = Nothing

MsgBox "完了しました。"

Exit Sub

If con.State = 1 Then con.Close

Set con = Nothing

MsgBox "エラーが発生しています。"

End Sub

Sub DataDelte()

On Error GoTo e

Dim w As Worksheet: Set w = Sheets("表紙")

yesno = MsgBox(w.Cells(6, 2).Text & "の日付で登録したデータは全て削除されます。よろしいですか？", vbYesNo)

If yesno = vbNo Then Exit Sub

Set con = CreateObject("adodb.connection")

con.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & ThisWorkbook.Path & "/sales.mdb")

q = "delete from SalesTable where 売上年月日 = #" & w.Cells(6, 2).Text & "#"

con.Execute q

If con.State = 1 Then con.Close

Set con = Nothing

MsgBox "完了しました。"

Exit Sub

If con.State = 1 Then con.Close

Set con = Nothing

MsgBox "エラーが発生しています。"

End Sub