Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

2396 / 76734

←次へ　｜　前へ→


	【79981】エラーが出てしまいます。どこを修正したらいいのでしょうか。

KAZUE - 18/6/11(月) 20:53 -


	引用なし

	パスワード

VBAの勉強を始めたばかりなのですが、
仕事で必要になり色々教えていただき以下のようにできたのですが、

「 '小計」の部分の「 r(i, 6) = r(i, 3) * r(i, 5)」まで来ると
実行時エラー１３　型が一致しません。と出てしまいます。
ちなみに小計を出したいのは、 Set sh2 = Worksheets("明細書")の
シートなのですが、どこを修正していいのかわかりません。

どなたか、教えていただけますでしょうか。

Sub サンプル()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim sdate As String, edate As String
Dim date1 As Date, date2 As Date
Dim i As Long, imax As Long, j As Long
　Dim place As String
sdate = InputBox("開始日を yyyy/m/d の形式で入力して下さい")
If sdate = "" Then Exit Sub
If IsDate(sdate) = False Then
MsgBox "日付エラー"
Exit Sub
End If
edate = InputBox("終了日を yyyy/m/d の形式で入力して下さい")
If edate = "" Then Exit Sub
If IsDate(edate) = False Then
MsgBox "日付エラー"
Exit Sub
End If
date1 = DateValue(sdate)
date2 = DateValue(edate)
If date1 > date2 Then
MsgBox "開始日>終了日エラー"
Exit Sub
End If
Application.ScreenUpdating = False
Set sh1 = Worksheets("作業シート")
Set sh2 = Worksheets("明細書")

'初期化
With sh1
If .Range("A1").Value <> "" Then
.Range("A5:Z" & .Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
End If
End With
With sh2
If .Range("B7").Value <> "" Then '**
.Range("A7:J" & .Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
　 End If
End With

'抽出
With Worksheets("データ")
For i = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
If .Range("A" & i).Value >= date1 And .Range("A" & i).Value <= date2 Then
j = j + 1
.Range("A" & i & ":X" & i).Copy Destination:=sh1.Range("A" & j)
End If
Next i
End With

'明細書作成
j = 9
With sh1
imax = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("A1:X" & imax).Sort Key1:=.Range("C1"), Order1:=xlAscending, Key2:=.Range("A1"), order2:=xlAscending
　For i = 1 To imax
If .Range("C" & i).Value <> place Then
j = j + 3
　sh2.Range("B" & j).Value = "【" & .Range("C" & i).Value & "】"
place = .Range("C" & i).Value
　svdate = 0
End If
j = j + 1
If .Range("A" & i).Value <> svdate Then
sh2.Range("A" & j).Value = .Range("A" & i).Value
sh2.Range("A" & j).NumberFormatLocal = "m/d"
svdate = .Range("A" & i).Value
svdate = .Range("A" & i).Value
End If
sh2.Range("B" & j).Value = .Range("D" & i).Value & " No." & .Range("P" & i).Value
sh2.Range("C" & j).Value = .Range("Q" & i).Value
sh2.Range("D" & j).Value = .Range("F" & i).Value
sh2.Range("E" & j).Value = .Range("O" & i).Value
sh2.Range("F" & j).Value = .Range("X" & i).Value
sh2.Range("J" & j).Value = .Range("R" & i).Value
Next i
End With

'小計
Dim r As Range
Range("C2").Resize(2).ClearContents
With Range("B12", Cells(Rows.Count, "B").End(xlUp))
For Each r In .SpecialCells(xlCellTypeConstants).Areas
r(r.Count + 1) = "小計"
For i = 2 To r.Count
r(i, 6) = r(i, 3) * r(i, 5)
r(i, 7) = r(i, 6) * 0.08
r(i, 8) = r(i, 2) + r(i, 6) + r(i, 7)
Next
r(r.Count + 1, 2) = Application.Sum(r.Offset(, 1))
r(r.Count + 1, 6) = Application.Sum(r.Offset(, 5))
r(r.Count + 1, 7) = Application.Sum(r.Offset(, 6))
r(r.Count + 1, 8) = Application.Sum(r.Offset(, 7))
Next r
End With

Application.ScreenUpdating = True
sh2.Select
End Sub

4 hits

▼

【79981】エラーが出てしまいます。どこを修正したらいいのでしょうか。 KAZUE 18/6/11(月) 20:53