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

No.2 ベストアンサー 回答者： WindFaller 回答日時： 2018/06/12 09:58

苦心して作れらたような気がしますが、コードからは、少しも、次の部分が想像できないのです。

アイデアとしては面白いのですが、こういう場合は、地道に、ふつうのFor Each や　For i=初期値のスタイルのほうが確実です。

>For Each r In .SpecialCells(xlCellTypeConstants).Areas

r は、Range型ですが、r(r.Count +1)　は、Areas から、Area を取り出したら、Area を、もし、細分化するなら、もうCells の単位になってしまいます。

それに、r が、Areaなら、
>r(i, 6) = r(i, 3) * r(i, 5)
２次元配列になることはないはずです。

これ自体が、Cellsの間違いではないでしょうか。この様子ですと、必ず、行になっていないといけないはずです。Area は、そういう制限がありません。通常、こういう場合は、最初から行で処理しますが、その中身は、やはりCells で行います。

今、元の表が見えないので想像で言うのですが、今のままでは、Areas でくくるのは辞めたほうが良いような気がします。意外に難しいというか、安定が悪いように思うのです。

言葉だけではわかりにくいかもしれません。

この回答へのお礼

ありがとうございます。
やっぱりVBAは難しいですね。

他のやり方を考えてみます。そして、Areaの使い方をもう少し勉強します。
参考になりました。

お礼日時：2018/06/15 11:31

No.1 回答者： よろずやkinchan 回答日時： 2018/06/11 22:45

せめてシートの画像位ないと、コードだけで推測するのは厳しい。

この回答へのお礼

ありがとうございます。仕事で使っているパソコンからの質問でないため、画像が取れませんでした。
何か他の方法を探してみます。

お礼日時：2018/06/15 11:29