| |
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
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
